perm filename POINTY.OLD[PNT,HE]2 blob
sn#327510 filedate 1978-01-04 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00037 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 BEGIN
C00013 00003 ! facilities: error messages,syntax explanations
C00028 00004 ! facilities: abort,abort1,recover,flrecover
C00040 00005 ! facilities: display inizialization, ttysave, default instructions,helprequest
C00051 00006 ! symbol table: definition, inizialization, basic procedures
C00060 00007 ! arithmetic: operations on matrices,assignment/extraction of values
C00070 00008 ! arithmetic: operations on arrays (norm,vcross,vsub)
C00079 00009 ! frame tree: unlnk_node, is_ancestor, lnk_node
C00086 00010 ! state saved: stacks, indexes and routines
C00095 00011 ! display: tree_string,dpy_string,file_string,update
C00107 00012 ! symbol table: costruction of records, and insertion in $YMTAB
C00118 00013 ! symbol table: control,insertion,declcode,killtree,killvar
C00132 00014 ! arithmetic: absxf, setabsxf, absset, relset, absloc, relloc,copyrtfr,copyvtfr
C00137 00015 ! arith. operations: opscal,opscvt,opdot,opvet,oprtrt,oprtvt,opfrvt,mulrtrt
C00146 00016 ! arith. operations: asgcode,absvtcomp,relvtcomp,expfrcode,expvtcode
C00155 00017 ! arith. operations: arithcode,constrcode,unitcode,axiscode
C00165 00018 ! tree operations: affixcode,unfixcode (afx_node)
C00173 00019 ! tree operations: copycode,copy,copy_tree
C00181 00020 ! arm interactions: read_pos,readarm,asgloc,frasg,inputcode
C00188 00021 ! arm interactions: arm_check,goarm,movefrfr
C00197 00022 ! arm interactions: mvfrcode,mvfrexp
C00208 00023 ! arm interactions: freecode,centercode,closecode,opencode,implconstr
C00214 00024 ! input/output: altf,altrans,alframe,aldec,al_subtree,alid, (unique_id)
C00222 00025 ! input/output: readexec,readcode,writecode,alfile,close,al_close
C00231 00026 ! system facilities: editcode,killcode,killtree,killvar
C00247 00027 ! parse: number,nums,gettoken,namefile
C00257 00028 ! parse: scalread,arrow_read,comma_read,semicol_read,rpar_read,lpar_read,idf_read,to_read,
C00267 00029 ! parse: rt_read, vt_read,vect_part,rot_part,trans_part,explicit
C00273 00030 ! parse procedures: affixproc,assign,bailcall
C00279 00031 ! parse procedures: centerproc,opclproc,constread,copyproc
C00286 00032 ! parse procedures: declproc,deleteproc,driveproc,editproc,exitproc,explass,freeproc
C00295 00033 ! parse procedures: inputproc,killproc,vtrtpart,moveproc,axmovproc
C00303 00034 ! parse procedures: other
C00307 00035 ! parse procedures: parking,readproc,renmproc,writeproc,unfixproc
C00310 00036 ! parse
C00316 00037 ! main program
C00331 ENDMK
C⊗;
BEGIN
EXTERNAL INTEGER !SKIP!;
DEFINE ALT ="'775",
SEMC = "'73",
SP = "'40",
CR = "'15",
LF ="'12",
CRLF = "('15&'12)",
DLF = "('15&'12&'12)",
TAB = "'11",
FF = "'14",
! = "COMMENT ",
TV = "'13";
REQUIRE 300 STRING_PDL;REQUIRE 1000 SYSTEM_PDL;
DEFINE #DEG = "(3.141592653/180.0)"; ! for radians/degrees conversion;
DEFINE RCLASS "<>" = <RECORD_CLASS>;
DEFINE RPTR "<>" = <RECORD_POINTER>;
DEFINE RANY "<>" = <RECORD_POINTER(ANY_CLASS)>;
! if /nB is set in the command line then assume he wants a debugging parser;
require "<><>" delimiters;
ifc ¬declaration(#debug) thenc
define
decipher_debug(a)=<
assignc a=cvms(compiler!banner)[2 to ∞-1];
assignc a=cvps(a)[length(scanc(cvps(a), lf, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), tab, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), sp, null, "IA"))+1 for 1];
"a">;
ifc decipher_debug()="0"
thenc define #debug=false;
elsec define #debug=true;
endc
endc
IFCR NOT DECLARATION(#HELP) THENC DEFINE #HELP =FALSE; ENDC
! the program is compiled without helping facilities;
STRING $LINE,$NEXT,$TAIL,$HEAD;
! $line is the line typed on tty;
! $next is the part of $line to be parsed;
! $tail is the part of instr. to be scanned until;
! $head is the last token read;
INTEGER $TYPE; ! type of last token read by gettoken;
DEFINE #IDF = 0,
#INT = 1,
#FLN = 2,
#PCT = 3;
! $TYPE = #IDF for identifier,
#INT for integer,
#FLN for real,
#PCT for punctuation mark;
DEFINE #MX = 5; ! used for mixed type assignments;
DEFINE #SC = 0,
#VT = 1,
#FR = 3,
#RT = 2,
#TR = 4;
! obtype = #SC for scalar,
#VT for vector,
#RT for rot,
#FR for frame,
#TR for trans;
LABEL MAINL; ! used by abort procedures to go to the top level;
! DEFINE #UP = 1;
! DEFINE #DOWN = -1;
DEFINE #INDEF = 0;
! direct = #INDEF for not defined direction,
#UP for ↑,
#DOWN for ↓;
DEFINE #INDLK = 0; ! affix type = independent link;
DEFINE #NRGLK = 1; ! affix type = non rigid link;
DEFINE #RGDLK = 2; ! affix type = rigid link;
DEFINE #MAXDPT = 10; ! #MAXDPT of frame tree for display;
DEFINE #SORRY "<>" = <("sorry, not implemented "&CRLF)>;
! used for non implemented parts message;
DEFINE #NOTYET "<>" = <("yarm not yet available "&CRLF)>;
! used for non implemented parts message;
REAL $EPS;
INTEGER $BRCHR,$EOF;
INTEGER $RETAB,$SKTAB,$SPCTAB,$SCNTAB,$NUMTAB,$ALFTAB,$DSHTAB,$ERRTAB,
$BSKTAB,$CMNTAB,$FFTAB;
PROCEDURE INIBRK;
BEGIN
STRING BTABLE;
BTABLE←".,;[]()+-*/←↑↓→?"&LF&CR&TAB&FF&SP &"<>∨∧α|";
SETBREAK ($SCNTAB←GETBREAK,";?{",CR&LF&FF&TV,"INAK"); ! general table;
SETBREAK ($RETAB ←GETBREAK,BTABLE,NULL,"INR"); ! used by gettoken;
SETBREAK ($SKTAB ←GETBREAK,BTABLE,NULL,"INS");
SETBREAK ($SPCTAB←GETBREAK,TAB&SP,NULL, "XNR");
SETBREAK ($ALFTAB←GETBREAK,NULL,NULL,"XRN");
SETBREAK ($NUMTAB←GETBREAK,"@+-0123456789",NULL,"XNR"); ! as table 10;
SETBREAK ($CMNTAB←GETBREAK,"}",NULL,"INA"); ! used for comments;
SETBREAK ($DSHTAB←GETBREAK,"_",NULL,"INS"); ! used by COPY/MERGE;
SETBREAK ($ERRTAB←GETBREAK,BTABLE,SP&CR,"IN"); ! used while recovering;
SETBREAK ($BSKTAB←GETBREAK,NULL,SP,"IN"); ! used for display;
SETBREAK ($FFTAB←GETBREAK,FF,NULL,"IN"); ! used by SAVE;
SETFORMAT(0,3);
END;
REQUIRE INIBRK INITIALIZATION ;
INTEGER $ALLOW; ! when >0 no display updating;
BOOLEAN $READ; ! true while reading from a file;
STRING ARRAY $NAMEFL[1:10] ; ! symbol table of files used;
INTEGER ARRAY $CHNFL[1:10,0:1]; ! open/closed and ch #;
INTEGER $TOTFL; ! number of files defined;
STRING $ALFL; ! last file used for output;
INTEGER $ALCH; ! $ALCH=channel used for output;
INTEGER $INPCH; ! channel # for current reading;
BOOLEAN $OUT; ! if true output is required;
INTEGER $TTYCH; ! channel # to output any tty input;
STRING $TTYFL; ! name of file for tty input
(if output is true);
BOOLEAN OLDVAL; ! to convert tty input to upper cases;
STRING $TRLST,$FRLST,$SCLST,$VTLST,$RTLST,$OULST; ! used for the display;
! facilities: error messages,syntax explanations;
INTEGER $HELP; ! used by abort;
INTEGER $LAST; ! used by kill;
! error messages for syntactic errors;
PRESET_WITH
"--→ ; ",
"--→ , ",
"--→ . ",
"--→ [ ",
"--→ ] ",
"--→ ( ",
"--→ ) ",
"--→ + ",
"--→ * ",
"--→ ALONG ",
"--→ BY ",
"--→ INTO ",
"--→ REL ",
"--→ ROT ",
"--→ TO ",
"--→ TRANS ",
"--→ WRT ",
"--→ XHAT or YHAT or ZHAT ",
"--→ YARM or BARM ",
"--→ YHAND or BHAND ",
"--→ INPUT after ↑, ↓, ∨, ∧, <, >",
"--→ identifier ",
"--→ number ",
"--→ file name ",
"--→ arithmetic operator ",
"required ←--",
"--→ error in explicit ",
"vector ←--",
"rotation ←--",
"frame ←--",
"--→ affix_type is wrong ←--",
"--→ wrong identifier or wrong number ←--",
"--→ unrecognized instruction ←--",
"| ",
"VECTOR required after DISTANCE";
STRING ARRAY $SYNMSG[0:34];
! error messages used for semantic errors;
PRESET_WITH
" scalar not existent ",
" vector not existent ",
" rotation not existent ",
" frame not existent ",
" backwards affixment",
" incorrect tree structure",
" object not existent ",
" out of symbol table",
" cannot be moved ",
" already defined symbol ",
" dismatching of types ",
" affixed frame ",
" reading on arm required ",
" enter failed ",
" file not existent ",
" not executed instruction",
" lookup failed for file ",
" is not scalar nor vector nor rotation ";
STRING ARRAY $SEMSG[0:17];
! $HLPMSG used to give information about the available instructions
or about the correct syntax of an incorrect instruction;
PRESET_WITH
"syntax of affixment:"&CRLF&
"AFFIX <frame_id> TO <frame_id>{AT TRANS(<rot>,{<scalar>*}<vector>)}{affixtype};"
&CRLF&"where <affixtype> = RIGIDLY or *, NONRIGIDLY or + "&
CRLF&"default = RIGIDLY"&CRLF,
"syntax of CLOSE:"&CRLF&
" CLOSE {<filename>}; default=closes all open files after confirmation"&CRLF&
" CLOSE <hand> TO <scalar>; or CLOSE <hand> BY <scalar>; "&CRLF&
"where <hand>=BHAND or YHAND and <scalar>=<number> or <scalar_id>"&CRLF,
"syntax of arithmetic expression:"&CRLF&
"<variable> ← <variable> <op> <variable>;"&CRLF&
"where <op> = + | - | * | / "&CRLF,
"syntax of assignment: <identifier>←<variable>;"&CRLF,
"syntax of general assignment:"&CRLF&
"variable>←<variable>; OR <variable>←<expression>;"&CRLF&
"where <expression> can be INPUT,CONSTRUCT,POS,ORIENT,arith.expr...."&CRLF,
"syntax of CENTER:"&CRLF&
"CENTER <arm>; where <arm>=BARM or YARM "&CRLF,
"syntax of OPEN or CLOSE:"&CRLF&
" OPEN <hand> TO <scalar>; for absolute movement"&CRLF&
" OPEN <hand> BY <scalar>; for differential movement"&CRLF&
"(analogous instructions for CLOSE)"&CRLF&
"where <hand>=BHAND or YHAND and <scalar>=<number> or <scalar_var>"&CRLF,
"syntax of CONSTRUCT:"&CRLF&
"<frame_id>←CONSTRUCT {<frame_id>,<frame_id>,<frame_id>};"&CRLF&
"<frame_id>←CONSTRUCT <vector_id>,<vector_id>,<vector_id>;"&CRLF&
"default= the system requires the frames"&CRLF,
"syntax of COPY or MERGE:"&CRLF&
"COPY <frame_id> INTO <frame_id>"&CRLF&
"MERGE <frame_id> INTO <frame_id>"&CRLF,
"syntax of declaration"&CRLF&
"<type><identifier>,<identifier>,...;"&CRLF&
" where <type> is SCALAR or VECTOR or ROT or FRAME"&CRLF,
"syntax of DELETE:"&CRLF&
"DELETE {<variable>,<variable>,.}.;"&CRLF&
"<variable> is a variable of any type.Frame deletion deletes the subtree"&CRLF&
"default= deletes any user defined variable"&CRLF,
"syntax of drive instructions: "&CRLF&
" DRIVE BJT(<joint #>) TO <scalar>; for absolute movement "&CRLF&
" DRIVE BJT(<joint #>) BY <scalar>; for differential movement "&CRLF&
" (YJT instead of BJT for YARM) to move the joint(integer between 1 and 7)"&CRLF,
"syntax of EDIT:"&CRLF&
"EDIT <variable>; where <variable> is a variable of any type"&CRLF,
"syntax of EXIT:"&CRLF&
"EXIT; also <meta-control-alt> performs an EXIT"&CRLF,
"syntax of INPUT:"&CRLF&
"<frame_id>←{<orient>} INPUT {<device>};"&CRLF&
"where <orient>= ↑ | ↓ | ∨ | ∧ | < | > "&CRLF&
"<device>=BARM or YARM or POINTER (default=POINTER)"&CRLF,
"syntax of KILL:"&CRLF&
"KILL;"&CRLF,
"syntax of POS:"&CRLF&
"<vector_id>←POS(<frame_id>);"&CRLF&
"<vector_id>←POS(INPUT {<device>});"&CRLF&
"where <device>=BARM or YARM or POINTER. Default= POINTER"&CRLF,
"syntax of MOVE:"&CRLF&
"MOVE <frame_id> TO <frame_id> {+|-{<scalar>*}<vector> {WRT <frame_id>}};"&CRLF&
"MOVE <frame_id> BY {{<scalar>*}<vector> {WRT <frame_id>}};"&CRLF&
"where <vector> can be <vector_id> or <explicit vector>"&CRLF,
"syntax of movement along an axis:"&CRLF&
"MOVE <frame_id> ALONG <axis> BY <scalar>; where <axis>=XHAT OR YHAT OR ZHAT"&
CRLF&"or MOVEX <frame_id> BY <scalar>; and analogous with MOVEY,MOVEZ "&CRLF,
"syntax of parking instructions: "&CRLF&
" BPARK; moves BARM to its park position"&CRLF&
" YPARK; moves YARM to its park position"&CRLF,
"syntax of ORIENT:"&CRLF&
"<rot_id>←ORIENT(<frame_id>);"&CRLF&
"<rot_id>←POS(INPUT {<device>});"&CRLF&
"where <device>=BARM or YARM or POINTER. Default= POINTER"&CRLF,
"syntax of READ:"&CRLF&
"READ {<filename>};"&CRLF&
"where <filename>=filnam.ext[prj,prg] (default=DECLAR.AL)"&CRLF,
"syntax of RENAME:"&CRLF&
"RENAME <variable>; where <variable> is a variable of any type"&CRLF,
"syntax of UNFIX:"&CRLF&
"UNFIX <frame_id> {FROM <frame_id>};"&CRLF,
"syntax of WRITE:"&CRLF&
"WRITE {<filename>} {FROM <frame>};"&CRLF&
"where <filename>=name.ext[prj,prg] (default=last used file or DECLAR.AL)"&CRLF&
"the default for <frame> is STATION"&CRLF,
"syntax of WRT or REL"&CRLF&
"<vector_id> ← <vector> WRT|REL <frame_id>;"&CRLF,
"syntax of explicit rotation assignment:"&CRLF&
"<rot_id>←{ROT}(<axis>,<scalar>);"&CRLF&
"where <axis>=XHAT or YHAT or ZHAT, and <scalar> is <scalar_id> or <number>"&CRLF,
"syntax of explicit vector assignment:"&CRLF&
"<vector_id>←{VECTOR}(<scalar>,<scalar>,<scalar>) {WRT|REL <frame_id>};"&CRLF&
"where <scalar> can be <scalar_id> or <number>"&CRLF,
"syntax of explicit frame assignment:"&CRLF&
"<frame_id>←(<scalar>,<scalar>,<scalar>,<scalar>,<scalar>,<scalar>){REL<frame_id>};"
&CRLF&"<frame_id>←FRAME(product of <rot>,{<scalar>*}<vector>) {REL <frame_id>};"
&CRLF,
"syntax of explicit assignment to vector or frame:"&CRLF&
"<vector_id>←(<scalar>,<scalar>,<scalar>) {WRT|REL <frame_id>};"&CRLF&
"<frame_id>←(<scalar>,<scalar>,<scalar>,<scalar>,<scalar>,<scalar>){REL<frame_id>};"&CRLF,
"syntax of SAVE:"&CRLF&
"SAVE {<filename>};"&CRLF&
"where <filename>=name.ext[prj,prg] (default=last used file or DECLAR.AL)"&CRLF,
" <identifier> ← <frame_id> + <vector_id>; (commutative)"&CRLF&
" <identifier> ← <frame_id> - <vector_id>;"&CRLF,
" <identifier> ← <rot_id> * <rot_id>;"&CRLF,
" <identifier> ← <scalar> * <vector_id>; (commutative)"&CRLF&
" <identifier> ← <vector_id> / <scalar>;"&CRLF&
" <identifier> ← <vector_id> + <vector_id>;"&CRLF&
" <identifier> ← <vector_id> - <vector_id>;"&CRLF&
" <identifier> ← <rot_id> * <vector_id>;"&CRLF&
" <identifier> ← <frame_id> * <vector_id>;"&CRLF,
" <identifier> ← <scalar> + <scalar>;"&CRLF&
" <identifier> ← <scalar> - <scalar>;"&CRLF&
" <identifier> ← <scalar> * <scalar>;"&CRLF&
" <identifier> ← <scalar> / <scalar>;"&CRLF&
" <identifier> ← <vector_id> * <vector_id>;"&CRLF,
" The big box displays the frame tree with"&CRLF&
" affixment type(-=INDEPENDENT,+=NONRIGID,*=RIGID), name, trans part."&CRLF&
" The box on the right displays the scalars, name and value."&CRLF&
" The little one below contains the default part for movement instructions."&CRLF&
" The three boxes below display: "&CRLF&
" the files used for output, with open/close(O or C), current default file(*),"&CRLF&
" name.The last indicated file is the file used to save TTY outputs;"&CRLF&
" the rotations, name and value expressed by Euler angles;"&CRLF&
" the vectors, name and value."&CRLF,
"an identifier is an alphanumeric string beginning with a letter"&CRLF,
" CLOSE_FILES; closes any open file, including the file used for TTY output"&CRLF,
"syntax of explicit trans assignment:"&CRLF&
"<trans_id>←(<scalar>,<scalar>,<scalar>,<scalar>,<scalar>,<scalar>);"
&CRLF&"<trans_id>←FRAME(product of <rot>,{<scalar>*}<vector>) ;"
&CRLF,
" syntax of UNIT"&CRLF&
"<identifier> ← UNIT(<vector>);"&CRLF,
" syntax of module operation:"&CRLF&
" <identifier> ← |<scalar>|; or <identifier> ← |<vector>|; or "&CRLF&
" <identifier> ← |<rot>|; "&CRLF,
" SAVE_FILES; saves any open file, including the file used for TTY output"
&CRLF,
" syntax of AXIS"&CRLF&
"<identifier> ← AXIS(<vector>);"&CRLF;
STRING ARRAY $HLPMSG[0:42];
! facilities: abort,abort1,recover,flrecover;
PROCEDURE ESC_P;
BEGIN
define ttyset = "'047000400121";
quick_code
hrroi 1,['004000000120]; comment [004000,,"P"];
ttyset 1, ; ! this last stuff does an esc-P;
end;
END;
! called after syntax error. If required gives explanation of the error;
PROCEDURE ABORT(STRING ERR1,ERR2);
BEGIN
STRING ANSWER;
PRINT (ERR1,ERR2,CRLF);
PRINT(" ",$HEAD," ",$TAIL,"(? for more explanation)");
ANSWER←INCHRW;IF ANSWER=CR THEN INCHRW;
PRINT(CRLF);
IF ANSWER="?"
THEN OUTSTR($HLPMSG[$HELP]); ! if required gives explanations;
IF NOT $READ THEN $ALLOW←0; ! while reading display is not updated;
$LAST←0; ! impossible to kill the instruction;
PRINT("* ");
ESC_P;
LODED($NEXT&CR); ! so it is possible to correct the command;
GO TO MAINL; ! goes to the main loop;
END;
! called after unrecoverable semantic error;
PROCEDURE ABORT1(STRING NAME,ERROR);
BEGIN
PRINT (NAME,"--→ ",ERROR,CRLF);
IF NOT $READ THEN $ALLOW←0; ! while reading display isn't updated;
$LAST←0; ! impossible to kill the instruction;
PRINT("* ");ESC_P;
LODED($NEXT&CR); ! so it is possible to correct the command;
GO TO MAINL; ! goes to the main loop;
END;
! called when an indefined variable is used. Tries to recover, asking
the correct name of the variable, and returns it.
(null string or <control-C> to return to the main loop);
STRING PROCEDURE RECOVER(STRING SYMB);
BEGIN "R"
STRING ANSWER;LABEL CC;
! you can change the identifier symb;
CC:
LODED(SYMB&CR);
ANSWER←INCHWL; ! reads new identifier;
IF $OUT THEN CPRINT($TTYCH,ANSWER,CRLF);
SYMB←SCAN(ANSWER,$ERRTAB,$BRCHR); ! eliminates blanks and checks break;
IF $BRCHR≠0 AND $BRCHR≠'40
THEN BEGIN
PRINT("break character found. Try again ");
GO TO CC; ! so... you can try again;
END
ELSE IF SYMB THEN RETURN(SYMB); ! a "good" symbol is returned;
! you want to delete the instruction being interpreted;
CLRBUF;
$LAST←0; ! impossible to kill the instruction;
IF NOT $READ THEN $ALLOW←0; ! no update of dislpay while reading;
PRINT($SEMSG[15],CRLF,"* ");
ESC_P;
GO TO MAINL; ! goes to the main loop;
END "R";
FORWARD STRING PROCEDURE NAMEFILE;
! allows recovering if a file not available has been required
(null string or <control-C> to return to the main loop);
STRING PROCEDURE FLRECOVER(STRING FILE);
BEGIN "F"
STRING ANSWER;
! you can change the name of the file;
LODED(FILE&CR);
ANSWER←INCHWL;
IF $OUT THEN CPRINT($TTYCH,ANSWER,CRLF);
$TAIL←SCAN(ANSWER,$BSKTAB,$BRCHR); ! scan to eliminate blanks;
! reads from tail and return a file name otherwise deletes the instr.;
IF $TAIL
THEN RETURN(NAMEFILE)
ELSE BEGIN
CLRBUF;
$LAST←0; ! impossible to kill the instruction;
IF NOT $READ THEN $ALLOW←0; ! no display update while reading;
PRINT($SEMSG[15],CRLF,"* ");
ESC_P;
GO TO MAINL; ! goes to thh main loop;
END;
END "F";
! facilities: display inizialization, ttysave, default instructions,helprequest;
REQUIRE "DPYSUB.HDR[SUB,SYS]" SOURCE_FILE;
INTEGER ARRAY ∂BUF[1:1000]; ! O NO?????? ;
INTEGER CHRSIZE,DPYCSIZE;
INTEGER $DLMAR,$DRMAR,$DTMAR,$DBMAR; ! whole display area;
INTEGER $CLMAR; ! cursor left margin for frame tree;
INTEGER $ATMAR; ! arithmetic display top margin;
INTEGER $FLMAR,$VTMAR; ! file display and rot. cursor left ;
INTEGER $DFMAR; ! default part top margin;
INTEGER $PTMAR; ! bottom margin of the box;
INTEGER AFXLINES,ARITHLINES; ! # of lines for frame tree and arithmetic;
INTEGER TREESPACE; ! width of space for frame tree;
INTEGER $NCHAR; ! # of characters for frame tree;
INTEGER ∂CHWID;
INTEGER ARRAY PPINFTBL[0:23];
DEFINE PPIOT "[]" = ['702000000000];
DEFINE PPINFO "[]" = [PPIOT 5,];
BOOLEAN PROCEDURE ONDD;
START_CODE
PPINFO PPINFTBL[0];
MOVE 1,PPINFTBL[2];
TLNN 1,'100000;
TDZA 1,1;
SETO 1,;
END;
SIMPLE PROCEDURE INIDPY;
BEGIN
CHRSIZE←20; ! I think;
DPYCSIZE←2;
IF ONDD THEN
BEGIN
$DLMAR←-625;
$DRMAR←580;
∂CHWID←15;
END
ELSE
BEGIN
$DLMAR←-510;
$DRMAR←510;
∂CHWID←12;
END;
$DTMAR←450;
$DBMAR←-510;
$CLMAR←$DRMAR-180;
$ATMAR←-70;
$DFMAR←-10;
$PTMAR←$DBMAR+($DTMAR-$DBMAR)*0.20;
AFXLINES←($DTMAR-$ATMAR)/CHRSIZE;
ARITHLINES←($ATMAR-$PTMAR)/CHRSIZE;
$FLMAR←$DLMAR+295;
$VTMAR←($DRMAR-$FLMAR)/2 + $FLMAR;
TREESPACE←$CLMAR-$DLMAR-10;
$NCHAR←TREESPACE/15;
END;
REQUIRE INIDPY INITIALIZATION [0];
INTEGER POG,ACTPOG,DPYBUF;
INTEGER ARRAY COMBUF[1:200];
IFC FALSE THENC BEGIN
! This function turns off all pieces of glass and outputs information.
As the user types a character all previously active pieces of glass
are restored;
PROCEDURE GIVEROOM;
BEGIN
ACTPOG←POGON; ! Remember which pieces of glass are on;
TYPLOC($DTMAR-CHRSIZE,$DBMAR+CHRSIZE);
POG←GETPOG; ! Get a free piece of glass;
ACPOGS(1 ROT -(POG+1)); ! Activate only the new POG;
DPYBUF←DPYPARS; ! Save the state of the DPY buffer;
DPYSET(COMBUF);
IF DPYTST≠1 THEN DPYOUT(POG);
CLRBUF;
END;
PROCEDURE BACK;
BEGIN
INTEGER FOO;
FOO←INCHRW; ! Wait for a character;
RELPOG(POG); ! Release POG;
ACPOGS(ACTPOG); ! Reactivate all previously active POGs;
DPYRESET(DPYBUF); ! Reset DPY buffer;
ESC_P;
END;
END;ENDC
SIMPLE PROCEDURE DRAWLINE(INTEGER X0,Y0,X1,Y1);
BEGIN
AIVECT(X1,Y1);
AVECT(X0,Y0);
END;
SIMPLE PROCEDURE DRAWBOX(INTEGER X0,Y0,X1,Y1);
BEGIN
AIVECT(X0,Y0);
AVECT(X0,Y1);
AVECT(X1,Y1);
AVECT(X1,Y0);
AVECT(X0,Y0);
END;
! saves on a file any tty input. The file can be managed only by AL_CLOSE;
! The AL_CLOSE instruction without parameters closes all open files and
asks for a new tty save file. Upon exit the file is automatically closed;
PROCEDURE TTYSAVE;
BEGIN
STRING ANSWER;
PRINT("file for TTY output=");
ESC_P;
ANSWER←INCHWL; CLRBUF;
$TAIL←SCAN(ANSWER,$BSKTAB,$BRCHR); ! scan to eliminate blanks;
! reads from tail and return a file name;
IF $TAIL
THEN BEGIN
ANSWER←NAMEFILE;
OPEN($TTYCH←GETCHAN,"DSK",0,0,2,0,0,$EOF);
$EOF←-1;
ENTER($TTYCH,ANSWER,$EOF);
WHILE $EOF
DO BEGIN
PRINT($SEMSG[13]);
ANSWER←FLRECOVER(ANSWER);
ENTER($TTYCH,ANSWER,$EOF);
END;
$OUT←TRUE;
$TTYFL←ANSWER;
END
ELSE $OUT←FALSE;
END;
STRING OLDCMD,OLDOBJ; ! used for default instructions;
! saves important parts of last instruction, for default instructions;
SIMPLE PROCEDURE OLDSAV(STRING CMD,OBJ);
BEGIN
OLDCMD←CMD;
OLDOBJ←OBJ;
END;
FORWARD PROCEDURE UPDATE;
! called after reading ?. Gives some information, erasing thh display;
SIMPLE PROCEDURE HELPREQUEST;
BEGIN "H"
LABEL LOOP;STRING ANSWER;
! prints on all the display;
DPYCLR;DPYSET(∂BUF);
TYPLOC($DTMAR-CHRSIZE,$PTMAR);DPYOUT(1);
! reads the comand after ?, if there is;
$TAIL←SCAN($LINE,$SCNTAB,$BRCHR);
LOOP:
IF NOT $TAIL
THEN BEGIN "I"
PRINT("information available on: S(calar),V(ector),R(otation),F(rame)",CRLF,
"T(ree),M(ove/arm reading),I(nput/output),E(dit/facilities),D(isplay)",CRLF,
"command? (<cr> to come back)");
CLRBUF;$TAIL←INCHRW;PRINT(CRLF);
END "I";
! prints the information according to the request;
IF $TAIL=CR
THEN BEGIN
$TAIL←INCHRW;
UPDATE;
RETURN;
END
ELSE IF $TAIL="D" OR $TAIL="d"
THEN PRINT(CRLF,$HLPMSG[35],CRLF)
ELSE IF $TAIL="E" OR $TAIL="e"
THEN PRINT(CRLF,$HLPMSG[12],CRLF,$HLPMSG[15],CRLF,$HLPMSG[22],CRLF,
$HLPMSG[13],CRLF)
ELSE IF $TAIL="F" OR $TAIL="f"
THEN PRINT(CRLF,$HLPMSG[9],CRLF,$HLPMSG[10],CRLF,
$HLPMSG[3],CRLF,$HLPMSG[28],CRLF,$HLPMSG[14],
CRLF,$HLPMSG[7],CRLF,$HLPMSG[31],CRLF)
ELSE IF $TAIL="I" OR $TAIL="i"
THEN PRINT(CRLF,$HLPMSG[21],CRLF,$HLPMSG[24],CRLF,$HLPMSG[1],CRLF)
ELSE IF $TAIL="M" OR $TAIL="m"
THEN PRINT(CRLF,$HLPMSG[17],CRLF,$HLPMSG[18],CRLF,$HLPMSG[19],CRLF,
$HLPMSG[11],CRLF,$HLPMSG[5],CRLF,$HLPMSG[6],CRLF,$HLPMSG[14],CRLF)
ELSE IF $TAIL="R" OR $TAIL="r"
THEN PRINT(CRLF,$HLPMSG[9],CRLF,$HLPMSG[10],CRLF,
$HLPMSG[3],CRLF,$HLPMSG[26],CRLF,$HLPMSG[20],CRLF,
$HLPMSG[32],CRLF)
ELSE IF $TAIL="S" OR $TAIL="s"
THEN PRINT(CRLF,$HLPMSG[9],CRLF,$HLPMSG[10],CRLF,
$HLPMSG[3],CRLF,$HLPMSG[34],CRLF)
ELSE IF $TAIL="T" OR $TAIL="t"
THEN PRINT(CRLF,$HLPMSG[0],CRLF,$HLPMSG[23],CRLF,$HLPMSG[8],CRLF)
ELSE IF $TAIL="V" OR $TAIL="v"
THEN PRINT(CRLF,$HLPMSG[9],CRLF,$HLPMSG[10],CRLF,
$HLPMSG[3],CRLF,$HLPMSG[27],CRLF,$HLPMSG[16],CRLF,
$HLPMSG[25],CRLF,$HLPMSG[33],CRLF)
ELSE PRINT("unrecognized key",CRLF);
$TAIL←NULL;
GO TO LOOP;
END "H";
! symbol table: definition, inizialization, basic procedures;
DEFINE #NTYPE = 4; ! 5 data types= 5 classes of records;
DEFINE #LMT = 499; ! total # of positions in symtab;
DEFINE #LTYPE = 100; ! #LTYPE=(#LMT+1)/(#NTYPE+1);
! # of postions in symtab for each class;
RCLASS SYMBOL (STRING PNAME;RANY OBJECT);
! pname=pname of the symbol;
! object=pointer to the record of the appropriate class;
RPTR (SYMBOL) ARRAY $YMTAB[0:#LMT]; ! symbol table;
INTEGER ARRAY $ENTRY[0:#NTYPE]; ! O NO????? ;
! each position (corresponding to one type) contains the index
of the first position free in $YMTAB for that class;
RCLASS SCALAR (REAL VALUE);
! value=value of the scalar;
RCLASS VECTOR (REAL XC,YC,ZC);
! xc,yc,zc=value of the component of the vector along x,y,z axis;
RCLASS FRAME (STRING PNAME; RPTR (FRAME) DAD,SON,EBRO,YBRO; INTEGER HOWLINKED;
REAL ARRAY XF);
! pname=pname of the frame;
! dad,son,ebro,ybro=pointers to dad,son,elder and younger brother
in frame tree;
! howlinked=kind of affixment(rigid,nonrigid,independent);
! xf=array of values
xf[1:3,1:3]=rotation matrix,
xf[1:3,4]=translation vector,
xf[4,1:3]=0,
xf[4,4]=1,
xf[5,1:3]=rotation angles,
xf[5,4]>0 if angles are valid;
RCLASS ROT (REAL ARRAY XF);
! xf=array of values (as for frame class);
RCLASS TRANS(REAL ARRAY XF);
! xf=array of values (as for frame class);
! records not entered in $YMTAB, used for computations;
INTEGER $ROW;
! row in $YMTAB of last checked symbol (used by kill operation);
! pointers to predeclared symbols;
RPTR(SYMBOL)HANDB,HANDY;
RPTR(SCALAR) S_BHAND,S_YHAND;
! for scalars BHAND,YHAND;
REAL BHAND; ! used by ARMINT to transfer the coordinates of BHAND;
RPTR(SYMBOL)XHAT,YHAT,ZHAT,NILVECT;
RPTR(VECTOR) V_XHAT,V_YHAT,V_ZHAT,V_NILVECT;
! for vectors XHAT,YHAT,ZHAT,NILVECT;
RPTR(SYMBOL)WORLD,BARM,YARM,BPARK,YPARK,BGRASP,POINTER;
RPTR(FRAME) F_WORLD,F_BARM,F_YARM,F_BPARK,F_YPARK,F_BGRASP,F_POINTER;
! for frames STATION,BARM,YARM,BPARK,YPARK,POINTER;
RPTR(SYMBOL)NILROTN;
RPTR(ROT) R_NILROTN;
! for rotation NILROTN;
RPTR(SYMBOL)NILTRANS;
RPTR(TRANS) T_NILTRANS;
! for trans NILTRANS;
RPTR(FRAME) ARM,F_FID;
! ARM points to the arm holding pointer,
F_FID points to the record FIDUCIAL (when defined);
RPTR(TRANS) PARK;
! to define the parking positions;
RPTR(TRANS) ARRAY IMPLF[1:3];
! used by CONSTRUCT instruction;
PROCEDURE INISYM; ! initialization of $ENTRY;
BEGIN
INTEGER I;
FOR I←0 STEP 1 UNTIL #NTYPE DO
$ENTRY[I]←I*#LTYPE;
END;
REQUIRE INISYM INITIALIZATION;
! checks if symbol symb, of type nm, is in symbol table in the class nm,
and return its pointer;
RPTR(SYMBOL) PROCEDURE CHECK(STRING SYMB;INTEGER NM);
BEGIN
RPTR(SYMBOL) TEMP;INTEGER IND,I;
IND←$ENTRY[NM]-1; ! address of $LAST record of type nm filled;
FOR I← NM*#LTYPE STEP 1 UNTIL IND DO
BEGIN
TEMP←$YMTAB[I];
IF TEMP≠NULL_RECORD
THEN IF EQU(SYMBOL:PNAME[TEMP],SYMB)
THEN BEGIN
$ROW←I;
RETURN(TEMP);
END;
END;
RETURN(NULL_RECORD); ! symbol not found;
END;
! checks if symbol symb is in symbol table, determines its class and
return its pointer;
RPTR(SYMBOL) PROCEDURE CHECKTOT(STRING SYMB;REFERENCE INTEGER NM);
BEGIN
INTEGER IND,I,K;RPTR(SYMBOL)TEMP;
FOR K←0 STEP 1 UNTIL #NTYPE DO
BEGIN
TEMP←CHECK(SYMB,K);
IF TEMP≠NULL_RECORD
THEN BEGIN
NM←K; ! changes the value of REFERENCE variable;
RETURN(TEMP);
END;
END;
RETURN(NULL_RECORD); ! symbol not found;
END;
! enters the symbol symb and the pointer to its node in symbol table,
in the class nm;
RPTR(SYMBOL) PROCEDURE ENSYM(STRING SYMB;INTEGER NM;RANY VAL);
BEGIN
RPTR (SYMBOL) TEMP;INTEGER IND;
IND←$ENTRY[NM]; ! address of $LAST record of type nm filled;
IF IND≥(NM+1)*#LTYPE
THEN ABORT1(" ",$SEMSG[7]); ! out of symbol table;
TEMP←NEW_RECORD(SYMBOL);
$YMTAB[IND]←TEMP; ! pointer to the new record in $YMTAB;
$ENTRY[NM]←IND+1; ! updating of $ENTRY;
SYMBOL:PNAME[TEMP]←SYMB; ! pname of symbol;
SYMBOL:OBJECT[TEMP]←VAL; ! pointer to the record previously created;
RETURN(TEMP);
END;
! deletes the symbol, whose pointer is el and whose class is obtype;
PROCEDURE DELSYM(RPTR(SYMBOL)EL;INTEGER OBTYPE);
BEGIN
INTEGER ADDRIN,ADDRFN,I;
ADDRIN←#LTYPE*OBTYPE; ! initial addr. in $YMTAB for class;
ADDRFN← $ENTRY[OBTYPE]-1; ! final addr. in $YMTAB for class;
FOR I←ADDRIN STEP 1 UNTIL ADDRFN DO
IF $YMTAB[I]=EL
THEN BEGIN
$YMTAB[I]←NULL_RECORD;
DONE;
END;
END;
! returns a new symbol, if symb is present in $YMTAB;
STRING PROCEDURE NEWSYM(STRING SYMB);
BEGIN
RPTR(SYMBOL)TEMP;INTEGER OBTYPE;
! if there is a symbol with the same pname allows recovering;
TEMP←CHECKTOT(SYMB,OBTYPE);
WHILE TEMP≠NULL_RECORD
DO BEGIN
PRINT(SYMB,$SEMSG[9]);
SYMB←RECOVER(SYMB);
TEMP←CHECKTOT(SYMB,OBTYPE);
END;
RETURN(SYMB);
END;
! checks if symb is present in $YMTAB and returns its pointer and its
type (using the reference variable obtype), otherwise allows recovering;
RPTR(SYMBOL) PROCEDURE OLDSYM(REFERENCE STRING SYMB;REFERENCE INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)EL;
EL←CHECKTOT(SYMB,OBTYPE);
! if symbol is not in $YMTAB, recovering is allowed;
WHILE EL=NULL_RECORD
DO BEGIN
PRINT ($SEMSG[6]);
SYMB←RECOVER(SYMB);
EL←CHECKTOT(SYMB,OBTYPE);
END;
RETURN(EL);
END;
! arithmetic: operations on matrices,assignment/extraction of values;
! computes C←A*B, where A=array, B,C = vectors[1:3];
SIMPLE PROCEDURE XFVTMUL(REAL ARRAY A,B,C);
BEGIN
INTEGER I,K;OWN REAL ARRAY TEMP[1:4];
FOR I←1 STEP 1 UNTIL 3 DO TEMP[I]←B[I];
TEMP[4]←1;
ARRCLR(C);
FOR I←1 STEP 1 UNTIL 3 DO
FOR K←1 STEP 1 UNTIL 4 DO C[I]←C[I]+A[I,K]*TEMP[K];
END;
! computes C ← A*B;
SIMPLE PROCEDURE XFXFMUL(REAL ARRAY A,B,C);
BEGIN
INTEGER I,J,K;
ARRCLR(C);
FOR I←1 STEP 1 UNTIL 3 DO
FOR J←1 STEP 1 UNTIL 4 DO
BEGIN
FOR K←1 STEP 1 UNTIL 4 DO C[I,J]←C[I,J]+A[I,K]*B[K,J];
END;
C[4,4]←1.0;
C[5,4]←0; ! angles are not valid;
END;
! computes B ← inv(A);
SIMPLE PROCEDURE XFINVRT(REAL ARRAY A,B);
BEGIN
INTEGER I,J;
ARRCLR(B);
FOR I←1 STEP 1 UNTIL 3 DO
FOR J ← 1 STEP 1 UNTIL 3 DO
BEGIN
B[I,J]←A[J,I];
B[I,4]←B[I,4]-B[I,J]*A[J,4];
END;
B[4,4]←1.0;
B[5,4]←0;
END;
! computes C ← inv(A)*B;
SIMPLE PROCEDURE INVXFXF(REAL ARRAY A,B,C);
BEGIN
OWN REAL ARRAY XFTMP[1:5,1:4];
XFINVRT(A,XFTMP);
XFXFMUL(XFTMP,B,C);
END;
! computes C ← inv(A)*B*A ;
SIMPLE PROCEDURE IABAMUL(REAL ARRAY A,B,C);
BEGIN
OWN REAL ARRAY XFTMP[1:5,1:4];
INVXFXF(A,B,XFTMP);
XFXFMUL(XFTMP,A,C);
END;
! computes C ← A*B*inv(A) ;
SIMPLE PROCEDURE ABIAMUL(REAL ARRAY A,B,C);
BEGIN
OWN REAL ARRAY AITMP,TMP[1:5,1:4];
XFINVRT(A,AITMP);
XFXFMUL(B,AITMP,TMP);
XFXFMUL(A,TMP,C);
END;
! computes the rotation part of XF to correspond to
ROT(Z,TH)*ROT(Y,PH)*ROT(Z,W), where the values of the angles are
expressed in degrees;
SIMPLE PROCEDURE SET_ROTATION(REAL ARRAY XF;REAL W,PH,TH);
BEGIN
REAL SW,CW,SPH,CPH,ST,CT;
SW←SIND(W);CW←COSD(W);
SPH←SIND(PH);CPH←COSD(PH);
ST←SIND(TH);CT←COSD(TH);
XF[1,1]←CW*CPH*CT-SW*ST;XF[1,2]←-CW*ST-SW*CPH*CT;XF[1,3]←SPH*CT;
XF[2,1]←CW*CPH*ST+SW*CT;XF[2,2]←CW*CT-SW*CPH*ST;XF[2,3]←SPH*ST;
XF[3,1]←-CW*SPH;XF[3,2]←SW*SPH;XF[3,3]←CPH;
XF[5,1]←W;XF[5,2]←PH;XF[5,3]←TH;
XF[5,4]←1.0;
END;
! computes the rotation part of XF to correspond to the rotation
by angle (in degrees) about axis (only XHAT, YHAT, ZHAT);
SIMPLE PROCEDURE AXIS_ROTATION(REAL ARRAY XF; REAL ANGLE,CX,CY,CZ);
BEGIN
REAL SVAL,CVAL,W,PH,TH;
SVAL←SIND(ANGLE);
CVAL←COSD(ANGLE);
XF[5,4]←0.;
XF[1,1]←CVAL+(1-CVAL)*CX↑2;
XF[2,2]←CVAL+(1-CVAL)*CY↑2;
XF[3,3]←CVAL+(1-CVAL)*CZ↑2;
XF[1,2]←(1-CVAL)*CX*CY-CZ*SVAL;
XF[2,1]←(1-CVAL)*CX*CY+CZ*SVAL;
XF[1,3]←(1-CVAL)*CX*CZ+CY*SVAL;
XF[3,1]←(1-CVAL)*CX*CZ-CY*SVAL;
XF[2,3]←(1-CVAL)*CY*CZ-CX*SVAL;
XF[3,2]←(1-CVAL)*CY*CZ+CX*SVAL;
END;
SIMPLE PROCEDURE XYZ_ROTATION(REAL ARRAY XF; STRING AXIS;REAL ANGLE);
BEGIN
IF AXIS="X"
THEN AXIS_ROTATION(XF,ANGLE,1,0,0)
ELSE IF AXIS="Y"
THEN AXIS_ROTATION(XF,ANGLE,0,1,0)
ELSE AXIS_ROTATION(XF,ANGLE,0,0,1);
END;
! returns the values of the angles (in degrees) from the rotation part
of XF. If the angles are valid (XF[5,4]>0) their values are in the fifth
row of XF, otherwise they have to be recomputed;
SIMPLE PROCEDURE DECODE_ROTATION(REAL ARRAY XF;REFERENCE REAL W,PH,TH);
BEGIN
IF XF[5,4]>0 THEN
BEGIN
W←XF[5,1];PH←XF[5,2];TH←XF[5,3];
END
ELSE
BEGIN
REAL SPH,CTH;
! since the function ATAN2 returns the value in radians
conversions to degrees are required;
PH←ATAN2(SQRT(XF[1,3]↑2 + XF[2,3]↑2),XF[3,3]);
PH←PH/#DEG; ! converts to degrees;
SPH←SIND(PH);
IF ABS(SPH)<$EPS THEN
BEGIN
PH←IF XF[3,3]>0 THEN 0 ELSE 180;
TH←0;
W←ATAN2(XF[2,1],XF[2,2]);
W←W/#DEG; ! converts to degrees;
SET_ROTATION(XF,W,PH,TH);
END
ELSE
BEGIN
W←ATAN2(XF[3,2],-XF[3,1]);
TH←ATAN2(XF[2,3],XF[1,3]);
W←W/#DEG; TH←TH/#DEG;
CTH←COSD(TH);
PH← IF $EPS<abs(CTH)
THEN ATAN2(XF[1,3]/CTH,XF[3,3])
ELSE ATAN2(XF[2,3]/SIND(TH),XF[3,3]);
PH←PH/#DEG; ! converts to degrees;
XF[5,1]←W;XF[5,2]←PH;XF[5,3]←TH;
XF[5,4]←1.0;
END;
END;
END;
! decodes the rotation matrix as a product of rotations about
the three main axes (used by ↑);
SIMPLE PROCEDURE DECODE (REAL ARRAY XF; REFERENCE REAL A,B,C);
BEGIN
REAL SA,CB;
IF ABS(XF[3,1])≤1
THEN B←ASIN(-XF[3,1])/#DEG
ELSE B←ATAN2(-XF[3,1],SQRT(XF[3,2]↑2 + XF[3,3]↑2))/#DEG;
CB←COSD(B);
IF ABS(CB)<$EPS THEN
BEGIN
A←0;
IF XF[3,1]<0 THEN B←90 ELSE B←-90;
END
ELSE BEGIN
C←ATAN2(XF[2,1],XF[1,1])/#DEG;
A←ATAN2(XF[3,2],XF[3,3])/#DEG;
SA←SIND(A);
IF B≠0 THEN
IF ABS(SA)≥$EPS
THEN B←ATAN2(-XF[3,1],XF[3,2]/SA)/#DEG
ELSE B←ATAN2(-XF[3,1],XF[3,3]/COSD(A))/#DEG;
END;
END;
! puts in the appropriate fields of the vector pointed by el the
values contained in the array comp;
SIMPLE PROCEDURE PUTVTVAL (RPTR(VECTOR) EL; REAL ARRAY COMP);
BEGIN
VECTOR:XC[EL]←COMP[1];
VECTOR:YC[EL]←COMP[2];
VECTOR:ZC[EL]←COMP[3];
END;
! puts xx,yy,zz in the fields xc,yc,zc of the vector pointed by el;
SIMPLE PROCEDURE PUTVT(RPTR(VECTOR)EL;REAL XX,YY,ZZ);
BEGIN
VECTOR:XC[EL]←XX;
VECTOR:YC[EL]←YY;
VECTOR:ZC[EL]←ZZ;
END;
! returns in the array comp the components of the vector pointed by el;
SIMPLE PROCEDURE GETVTVAL(RPTR(VECTOR) EL; REAL ARRAY COMP);
BEGIN
COMP[1]←VECTOR:XC[EL];
COMP[2]←VECTOR:YC[EL];
COMP[3]←VECTOR:ZC[EL];
END;
! returns in the array comp the translation components of the frame frn;
SIMPLE PROCEDURE GETVTFR (RPTR(FRAME) FRN;REFERENCE REAL X,Y,Z);
BEGIN
X←FRAME:XF[FRN][1,4];
Y←FRAME:XF[FRN][2,4];
Z←FRAME:XF[FRN][3,4];
END;
! returns in the array comp the translation components of the record TRANS;
SIMPLE PROCEDURE GETVTTR(RPTR(TRANS)XFE;REAL ARRAY COMP);
BEGIN
COMP[1]←TRANS:XF[XFE][1,4];
COMP[2]←TRANS:XF[XFE][2,4];
COMP[3]←TRANS:XF[XFE][3,4];
END;
! arithmetic: operations on arrays (norm,vcross,vsub);
! computes the norm of comp and returns results in comp;
SIMPLE PROCEDURE NORM(REAL ARRAY COMP);
BEGIN
INTEGER I; REAL M;
M←SQRT(COMP[1]↑2+COMP[2]↑2+COMP[3]↑2);
IF M≤$EPS THEN ABORT1("NORM NOT WELL DEFINED"," ");
FOR I←1 STEP 1 UNTIL 3 DO
COMP[I]←COMP[I]/M; ! attention:results in comp;
END;
! computes the norm of FIRST minus SECOND, and returns values in RESULT;
SIMPLE PROCEDURE NORMSUB(REAL ARRAY FIRST,SECOND,RESULT);
BEGIN
INTEGER I; REAL M;
FOR I←1 STEP 1 UNTIL 3 DO
RESULT[I]←FIRST[I]-SECOND[I];
NORM(RESULT);
END;
! computes the norm of the cross product of FIRST and SECOND, and returns
values in RESULT;
SIMPLE PROCEDURE NORMCROSS(REAL ARRAY FIRST,SECOND,RESULT);
BEGIN
RESULT[1]←FIRST[2]*SECOND[3]-FIRST[3]*SECOND[2];
RESULT[2]←FIRST[3]*SECOND[1]-FIRST[1]*SECOND[3];
RESULT[3]←FIRST[1]*SECOND[2]-FIRST[2]*SECOND[1];
NORM(RESULT);
END;
! frame tree: unlnk_node, is_ancestor, lnk_node;
! breaks links in frame tree for the frame N;
PROCEDURE UNLNK_NODE(RPTR(FRAME) N);
BEGIN
RPTR(FRAME) Y,E;
E←FRAME:EBRO[N];
IF (Y←FRAME:YBRO[N])=NULL_RECORD
THEN BEGIN
IF FRAME:DAD[N]≠NULL_RECORD THEN
FRAME:SON[FRAME:DAD[N]]←E;
END
ELSE FRAME:EBRO[Y]←E;
IF E≠NULL_RECORD THEN
FRAME:YBRO[E]←Y;
FRAME:EBRO[N]←NULL_RECORD;
FRAME:YBRO[N]←NULL_RECORD;
FRAME:DAD[N]←NULL_RECORD;
$FRLST←NULL;
END;
! returns true if D is an ancestor of N;
BOOLEAN PROCEDURE IS_ANCESTOR(RPTR(FRAME) N,D);
BEGIN
WHILE N≠NULL_RECORD DO
IF N=D
THEN RETURN(TRUE)
ELSE N←FRAME:DAD[N];
RETURN(FALSE);
END;
! sets #UP pointer structure in frame tree for N to be a child of D;
PROCEDURE LNK_NODE(RPTR(FRAME) N,D);
BEGIN
IF NOT(D=F_WORLD AND FRAME:HOWLINKED[N]=#INDLK)
THEN IF IS_ANCESTOR(D,N)
THEN ABORT1(" ",$SEMSG[4]);
IF FRAME:DAD[N]≠NULL_RECORD
THEN UNLNK_NODE(N);
IF (FRAME:EBRO[N]←FRAME:SON[D])≠NULL_RECORD THEN
FRAME:YBRO[FRAME:EBRO[N]]←N;
FRAME:YBRO[N]←NULL_RECORD;
FRAME:DAD[N]←D;
FRAME:SON[D]←N;
$FRLST←NULL; ! the frame tree is modified;
END;
! state saved: stacks, indexes and routines;
DEFINE #NW = -1;
DEFINE #NWFR= -2;
! type for new created symbols:
#NWFR=new created frame,
#NW=other new created symbol;
! declarations of stacks and pointers to their tops;
DEFINE #TOP = 30;
INTEGER ARRAY ADDRTYPE[0:#TOP,0:1];
! contains the entries of the symbol in $YMTAB and their type(#SC,#VT,#FR,#RT).
Whenever the symbols are new created symbols some special types are used
for easing the kill operation;
RPTR (SYMBOL) ARRAY ADDRPTR[0:#TOP];
! contains the rptr to the symbols (taken from $YMTAB);
REAL ARRAY SCVTSAVED[0:#TOP*2];
! contains the values of scalars and vectors. These values are saved
whenever the values of an existing scalar or vector are modified;
RPTR(TRANS) ARRAY RTFRSAVED[0:#TOP];
! contains the pointers to TRANS records, created for saving the
values of rot or frames, whenever they are modified;
RPTR(FRAME)ARRAY TREESAVED[0:#TOP,0:1];
! contains the rptr to the frames and their dad. These pointers are saved
each time the frame tree is modified;
INTEGER ARRAY LNKSAVED[0:#TOP];
! contains the values of the link between the frames and their dad (saved
in treesaved stack) each time the frame tree is modified;
INTEGER INDADDR;
! next position to fill in for addrtype,addrptr;
INTEGER INDSCVT;
! next position to fill in for scvtsaved;
INTEGER INDRTFR;
! next position to fill in for rtfrsaved;
INTEGER INDTREE;
! next position to fill in for treesaved,lnksaved;
DEFINE KIL= 0,
DECL=1,
DEL=2,
ASG=3,
AFX=4,
MRG=5,
CPY=6;
! information about the state is saved depending on the instruction:
kil=not killable instruction,
decl=declaration instruction,
del=deletion instruction,
asg=assignment instruction,
afx=affix or unfix instruction,
mrg=merge instruction,
cpy=copy instruction;
! initialization of indexes of stacks (called after each instruction);
PROCEDURE KILLINI;
BEGIN
INDADDR←INDSCVT←INDRTFR←INDTREE←0;
END;
! saves the information for a new symbol: only addrtype and addrptr
stacks are used;
PROCEDURE SAVENEW(RPTR(SYMBOL)EL;INTEGER TYPE);
BEGIN
IF INDADDR>#TOP
THEN BEGIN
PRINT("I can't save more variables",crlf);
$LAST←KIL; ! so the instruction is unkillable;
RETURN;
END;
ADDRPTR[INDADDR]←EL; ! pointer to the symbol;
ADDRTYPE[INDADDR,0]←$ENTRY[TYPE]-1; ! entry in $YMTAB(last created symb);
IF TYPE=#FR THEN ADDRTYPE[INDADDR,1]←#NWFR
ELSE ADDRTYPE[INDADDR,1]←#NW;
INDADDR←INDADDR+1; ! next position to fill in;
END;
FORWARD RPTR(TRANS) PROCEDURE NEW_XFELT;
! saves the information for existing symbols: information on $YMTAB is
inserted in addrtype and addrptr, previous values are saved in scvtsaved
or in rtfrsaved;
PROCEDURE SAVEOLD(RPTR(SYMBOL)EL;INTEGER TYPE);
BEGIN
RANY OBJ;RPTR(TRANS)TEMP;
IF INDADDR>#TOP
THEN BEGIN
PRINT("I can't save more variables",crlf);
$LAST←KIL; ! so the instruction is not killable;
RETURN;
END;
ADDRPTR[INDADDR]←el; ! pointer to the symbol;
ADDRTYPE[INDADDR,1]←TYPE; ! type;
ADDRTYPE[INDADDR,0]←$ROW; ! entry in $YMTAB;
INDADDR←INDADDR+1; ! next position to fill in;
OBJ←SYMBOL:OBJECT[EL];
CASE TYPE OF
BEGIN
[#SC] BEGIN
SCVTSAVED[INDSCVT]←SCALAR:VALUE[OBJ];
INDSCVT←INDSCVT+1; ! next position to fill in;
$SCLST←NULL;
END;
[#VT] BEGIN
SCVTSAVED[INDSCVT]←VECTOR:XC[OBJ];
SCVTSAVED[INDSCVT+1]←VECTOR:YC[OBJ];
SCVTSAVED[INDSCVT+2]←VECTOR:ZC[OBJ];
INDSCVT←INDSCVT+3; ! next position to fill in;
$VTLST←NULL;
END;
[#RT] BEGIN
TEMP←NEW_XFELT; ! new record created to save values;
ARRTRAN(TRANS:XF[TEMP],ROT:XF[OBJ]);
RTFRSAVED[INDRTFR]←TEMP;
INDRTFR←INDRTFR+1; ! next position to fill in;
$RTLST←NULL;
END;
[#FR] BEGIN
TEMP←NEW_XFELT; ! new record created to save values;
ARRTRAN(TRANS:XF[TEMP],FRAME:XF[OBJ]);
RTFRSAVED[INDRTFR]←TEMP;
INDRTFR←INDRTFR+1; ! next position to fill in;
$FRLST←NULL
END;
[#TR] BEGIN
TEMP←NEW_XFELT; ! new record created to save values;
ARRTRAN(TRANS:XF[TEMP],TRANS:XF[OBJ]);
RTFRSAVED[INDRTFR]←TEMP;
INDRTFR←INDRTFR+1; ! next position to fill in;
$TRLST←NULL
END
END;
END;
! saves the structure of the tree;
PROCEDURE SAVETREE(STRING FNAME);
BEGIN
RPTR(SYMBOL)EL;RPTR(FRAME)FRN;
EL←CHECK(FNAME,#FR);
FRN←SYMBOL:OBJECT[EL];
SAVEOLD(EL,#FR); ! saves the values of the frame;
TREESAVED[INDTREE,0]←FRN; ! the pointer to the frame;
TREESAVED[INDTREE,1]←FRAME:DAD[FRN]; ! the pointer to its dad;
LNKSAVED[INDTREE]←FRAME:HOWLINKED[FRN]; ! the kind of affixment;
INDTREE←INDTREE+1; ! next position to fill in;
END;
! display: tree_string,dpy_string,file_string,update;
! eliminates all the blanks characters in the string (to reduce
the space when displayed);
SIMPLE STRING PROCEDURE CVGX(REAL R);
BEGIN
STRING S1,S2;
S1←CVG(R);
S2←SCAN(S1,$BSKTAB,$BRCHR);
RETURN(S2);
END;
STRING BLANKS;
SIMPLE PROCEDURE INISPA;
BEGIN
BLANKS←" ";
BLANKS←BLANKS&BLANKS;
BLANKS←BLANKS&BLANKS;
END;
REQUIRE INISPA INITIALIZATION [0];
! returns the trans part for the frame, whose values are in XF;
! returns a string with the rotation part;
STRING PROCEDURE STR_RT(REAL ARRAY XF;INTEGER NUM(1)); ! num=1 for file,=4 for display;
BEGIN
REAL W,PH,TH;
STRING RS,SCA;
STRING PROCEDURE ROTFORM(STRING AXIS;REAL W);
IF NUM=1
THEN RETURN("ROT("[NUM TO ∞]&AXIS[1 TO 5-NUM]&","&CVGX(W)
&"*DEGREES)")
ELSE RETURN("ROT("[NUM TO ∞]&AXIS[1 TO 5-NUM]&","&CVGX(W)&")");
DECODE_ROTATION(XF,W,PH,TH);
RS←NULL;SCA←NULL;
IF NUM=1 THEN SETFORMAT(0,5);
IF ABS(TH)>$EPS THEN
BEGIN
RS←RS&ROTFORM("ZHAT",TH);
SCA←"*";
END;
IF ABS(PH)>$EPS THEN
BEGIN
RS←RS&SCA&ROTFORM("YHAT",PH);
SCA←"*";
END;
IF ABS(W)>$EPS THEN
BEGIN
RS←RS&SCA&ROTFORM("ZHAT",W);
SCA←"*";
END;
IF LENGTH(SCA)=0 THEN
RS←RS&"NILROTN";
SETFORMAT(0,3);
RETURN(RS);
END;
! returns a string with the vector part for frame assignments;
SIMPLE STRING PROCEDURE STR_VT(REAL X,Y,Z;INTEGER NUM(1));
BEGIN ! num=1 for file,=8 for display;
STRING VECTOR,INCH;
IF ABS(X)<$EPS AND ABS(Y)<$EPS AND ABS(Z)<$EPS
THEN RETURN(IF NUM=1 THEN "NILVECT*INCHES" ELSE "NILVECT")
ELSE RETURN(" VECTOR("[NUM TO ∞]&CVGX(X)&","&CVGX(Y)&","&CVGX(Z)
&")*INCHES"[1 TO 9-NUM]);
END;
STRING PROCEDURE STR_TR(REAL ARRAY XF;INTEGER ROT(1),VECT(1));
BEGIN
! rot=1,vect=1 for file,rot=4,vect=7 for display;
REAL W,PH,TH,X,Y,Z; STRING RTPART,VTPART;
RTPART←STR_RT(XF,ROT);
X←XF[1,4];Y←XF[2,4];Z←XF[3,4];
VTPART←STR_VT(X,Y,Z,VECT);
IF ROT=1 THEN RETURN(" ("&RTPART&","&CRLF&BLANKS[1 TO 6]&VTPART&")")
ELSE RETURN(" ("&RTPART&","&VTPART&")");
END;
! returns a string with the frame tree (names , trans part and affixment
type for frames);
RECURSIVE STRING PROCEDURE FRTREE(RPTR(FRAME) ND;INTEGER DEPTH);
BEGIN
STRING TS;INTEGER L;
DEPTH←DEPTH+1;
IF DEPTH>#MAXDPT THEN RETURN(NULL);
TS←NULL;
L←DEPTH*2-1;
TS←TS&BLANKS[1 FOR L]&"-+*"[1+FRAME:HOWLINKED[ND] FOR 1]&FRAME:PNAME[ND]
&STR_TR(FRAME:XF[ND],4,8);
COMMENT PRINT($NCHAR," ",TS[1 FOR 10]," ",LENGTH(TS),CRLF);
IF LENGTH (TS)>$NCHAR
THEN TS←TS[1 TO $NCHAR-1]&CRLF&BLANKS[1 TO DEPTH*2-1]
&TS[$NCHAR TO ∞]&CRLF
ELSE TS←TS&CRLF;
ND←FRAME:SON[ND];
WHILE ND≠NULL_RECORD DO
BEGIN
! BPARK/YPARK not displayed;
IF ND≠F_BPARK AND ND≠F_YPARK
THEN TS←TS&FRTREE(ND,DEPTH);
ND←FRAME:EBRO[ND];
END;
RETURN(TS);
END;
STRING PROCEDURE TREE_STRING;
BEGIN
STRING TS;RPTR(FRAME)ND;
TS←"STATION (NILROTN,NILVECT)"&CRLF;
ND←FRAME:SON[F_WORLD];
WHILE ND≠NULL_RECORD DO
BEGIN
! BPARK/YPARK not displayed;
IF ND≠F_BPARK AND ND≠F_YPARK
THEN TS←TS&FRTREE(ND,0);
ND←FRAME:EBRO[ND];
END;
RETURN(TS);
END;
! returns a string with name and value of the variables of the
indicated type;
STRING PROCEDURE DPY_STRING(INTEGER TYPE);
BEGIN
INTEGER ADDRIN,ADDRFN,I;
RPTR(SYMBOL)ADDR;STRING TS;
ADDRIN←#LTYPE*TYPE; ! initial address in $YMTAB;
ADDRFN←$ENTRY[TYPE]-1; ! final address;
TS←NULL;
FOR I←ADDRIN STEP 1 UNTIL ADDRFN DO
BEGIN
ADDR←$YMTAB[I]; ! if null_record is a deleted symb;
IF ADDR≠NULL_RECORD
THEN CASE TYPE OF
BEGIN "case"
[#SC] TS←TS&" "&SYMBOL:PNAME[ADDR]&" "
&CVGX(SCALAR:VALUE[SYMBOL:OBJECT[ADDR]])&CRLF;
[#VT] BEGIN
RPTR(VECTOR)IND;
IND←SYMBOL:OBJECT[ADDR];
IF IND=V_NILVECT
THEN TS←TS&" NILVECT (.000,.000,.000)"&CRLF
ELSE
IF IND≠V_XHAT AND IND≠V_YHAT AND IND≠V_ZHAT
THEN TS←TS&" "&SYMBOL:PNAME[ADDR]&" "
&STR_VT(VECTOR:XC[IND],VECTOR:YC[IND],
VECTOR:ZC[IND],8)&CRLF;
END;
[#RT] BEGIN
RPTR(ROT) IND;
IND←SYMBOL:OBJECT[ADDR];
IF IND=R_NILROTN
THEN TS←TS&" NILROTN (Z,.000) "&CRLF
ELSE TS←TS&" "&SYMBOL:PNAME[ADDR]&" ("
&STR_RT(ROT:XF[SYMBOL:OBJECT[ADDR]],4)&
")"&CRLF;
END;
[#TR] BEGIN
IF ADDRIN<ADDRFN AND I = ADDRIN
THEN TS←TS
ELSE TS←TS&" "&SYMBOL:PNAME[ADDR]
&STR_TR(TRANS:XF[SYMBOL:OBJECT[ADDR]],4,8)&CRLF
END
END "case";
END;
RETURN (TS);
END;
! returns a string with the names of files used for output and their
state (open/closed);
STRING PROCEDURE FILE_STRING;
BEGIN
INTEGER I;STRING TS;
TS←NULL;
FOR I←1 STEP 1 UNTIL $TOTFL
DO BEGIN
IF EQU($NAMEFL[I],$ALFL)
THEN TS←TS&"*"
ELSE TS←TS&" ";
TS←TS&"OC"[1+$CHNFL[I,0] FOR 1]&":"&$NAMEFL[I]&CRLF;
END;
RETURN(TS);
END;
SIMPLE STRING PROCEDURE DEFAULT;
RETURN(" "&OLDCMD&CRLF&" "&OLDOBJ&CRLF);
PROCEDURE OUTBLK(STRING STR;INTEGER X,Y,WID,NLINES,SIZE);
BEGIN
INTEGER B,BRK,NCHAR;STRING S,T;LABEL L;
B←12;
SETBREAK(B,CR,CRLF,"INS");
NCHAR←WID/∂CHWID;
WHILE STR DO
BEGIN
S←SCAN(STR,B,BRK);
IF BRK≠CR THEN DONE;
WHILE S DO
BEGIN
IF LENGTH(S)>NCHAR
THEN BEGIN
T←S[1 FOR NCHAR];S←S[NCHAR+1 FOR ∞];
END
ELSE BEGIN
T←S;S←NULL;
END;
AIVECT(X,Y);
DPYSST(T);
Y←Y-SIZE;
IF (NLINES←NLINES-1)≤0 THEN GO TO L;
END;
END;
L: END;
! update the display (if $ALLOW=0);
PROCEDURE UPDATE;
BEGIN
IF $ALLOW>0 THEN RETURN;
DPYSET(∂BUF);
DPYBIG(DPYCSIZE);
TYPLOC($PTMAR-CHRSIZE,$DBMAR);
DRAWBOX ($DLMAR,$DTMAR,$DRMAR,$PTMAR);
DRAWLINE($CLMAR,$DTMAR,$CLMAR,$ATMAR);
DRAWLINE($CLMAR,$DFMAR,$DRMAR,$DFMAR);
DRAWLINE($DLMAR,$ATMAR,$DRMAR,$ATMAR);
DRAWLINE($FLMAR,$ATMAR,$FLMAR,$PTMAR);
DRAWLINE($VTMAR,$ATMAR,$VTMAR,$PTMAR);
IF NOT $SCLST THEN $SCLST←DPY_STRING(#SC);
IF NOT $VTLST THEN $VTLST←DPY_STRING(#VT);
IF NOT $RTLST THEN $RTLST←DPY_STRING(#RT);
IF NOT $TRLST THEN $TRLST←DPY_STRING(#TR);
IF NOT $FRLST THEN $FRLST←TREE_STRING;
IF NOT $OULST THEN $OULST←FILE_STRING;
OUTBLK($FRLST,
$DLMAR+5,$DTMAR-CHRSIZE-5,
TREESPACE,AFXLINES-6,CHRSIZE); ! ERA -1;
OUTBLK($SCLST,
$CLMAR+5,$DTMAR-CHRSIZE-5,
$DRMAR-$CLMAR-10,AFXLINES-4,CHRSIZE);
OUTBLK(DEFAULT,
$CLMAR+5,$DFMAR-CHRSIZE-5,
$DRMAR-$CLMAR-10,3,CHRSIZE);
OUTBLK($TRLST,
$DLMAR+5,$DFMAR-2*CHRSIZE-5,
TREESPACE,6,-CHRSIZE);
OUTBLK($VTLST,
$VTMAR+5,$ATMAR-CHRSIZE-5,
$DRMAR-$VTMAR-10,ARITHLINES,CHRSIZE);
OUTBLK($RTLST,
$FLMAR+5,$ATMAR-CHRSIZE-5,
$VTMAR-$FLMAR-10,ARITHLINES,CHRSIZE);
OUTBLK($OULST,
$DLMAR+5,$ATMAR-CHRSIZE-5,
$FLMAR-$DLMAR-10,ARITHLINES-2,CHRSIZE);
IF $OUT
THEN OUTBLK(" "&$TTYFL&CRLF,
$DLMAR+5,$PTMAR + CHRSIZE+5,
$FLMAR-$DLMAR+10,1,CHRSIZE);
DPYOUT(1);
ESC_P;
END;
! symbol table: costruction of records, and insertion in $YMTAB;
! defines a new scalar record and inserts it in $YMTAB;
RPTR (SYMBOL) PROCEDURE NEW_SC (STRING SYMB);
BEGIN
RPTR(SCALAR) VAL;RPTR(SYMBOL) TEMP;INTEGER OBTYPE;
! if symb exists allows recovering and returns a new symbol;
SYMB←NEWSYM(SYMB);
VAL←NEW_RECORD(SCALAR); ! creates a new record;
TEMP←ENSYM(SYMB,#SC,VAL); ! enters in $YMTAB;
SAVENEW(TEMP,#SC); ! saves it(for kill operation);
$SCLST←NULL;
UPDATE; ! updates the display;
RETURN(TEMP);
END;
! define a new vector record and enter it in $YMTAB;
RPTR(SYMBOL) PROCEDURE NEW_VT (STRING SYMB);
BEGIN
RPTR(VECTOR) VAL;RPTR(SYMBOL) TEMP;INTEGER OBTYPE;
SYMB←NEWSYM(SYMB);
VAL←NEW_RECORD(VECTOR); ! creates a new record;
TEMP←ENSYM(SYMB,#VT,VAL); ! enters in $YMTAB;
SAVENEW(TEMP,#VT); ! saves it (for kill operation);
$VTLST←NULL;
UPDATE; ! updates the display;
RETURN(TEMP);
END;
! define a new frame record, enter it in $YMTAB and affix
to WORLD indipendently;
RPTR (SYMBOL) PROCEDURE NEW_FR (STRING SYMB);
BEGIN
INTEGER OBTYPE;
RPTR (FRAME) VAL; RPTR (SYMBOL) TEMP;
REAL ARRAY A[1:5,1:4];
SYMB←NEWSYM(SYMB);
VAL←NEW_RECORD(FRAME); ! creates a new record;
TEMP←ENSYM(SYMB,#FR,VAL); ! enters in $YMTAB;
FRAME:PNAME[VAL]←SYMB; ! pname;
A[1,1]←A[2,2]←A[3,3]←A[4,4]←1.0; ! initial values;
A[5,4]←1.0;
MEMORY[LOCATION(A)]↔MEMORY[LOCATION(FRAME:XF[VAL])];
IF NOT EQU(SYMB,"STATION")
THEN LNK_NODE(VAL,F_WORLD); ! affixes to WORLD;
FRAME:HOWLINKED[VAL]←#INDLK; ! independently;
SAVENEW(TEMP,#FR); ! saves (for kill operation);
$FRLST←NULL;
UPDATE; ! updates the display;
RETURN(TEMP);
END;
! construct a new record rot;
RPTR (SYMBOL) PROCEDURE NEW_RT (STRING SYMB);
BEGIN
INTEGER OBTYPE;
RPTR (ROT) VAL;RPTR(SYMBOL)TEMP;
REAL ARRAY A[1:5,1:4];
SYMB←NEWSYM(SYMB);
VAL←NEW_RECORD(ROT); ! creates a new record;
TEMP←ENSYM(SYMB,#RT,VAL); ! enters in $YMTAB;
A[1,1]←A[2,2]←A[3,3]←A[4,4]←1.0; ! initial values;
! A[5,4]←1.0;
MEMORY[LOCATION(A)]↔MEMORY[LOCATION(ROT:XF[VAL])];
SAVENEW(TEMP,#RT); ! saves (for kill operation);
$RTLST←NULL;
UPDATE; ! updates the display;
RETURN (TEMP);
END;
! construct a new record TRANS, not inserted in $YMTAB;
RPTR (TRANS) PROCEDURE NEW_XFELT;
BEGIN
REAL ARRAY XF[1:5,1:4];
RPTR(TRANS)X;
INTEGER I;
X←NEW_RECORD(TRANS); ! creates a new record;
FOR I←1 STEP 1 UNTIL 4 DO
XF[I,I]←1.0; ! initial values;
! XF[5,4]←1.0;
MEMORY[LOCATION(TRANS:XF[X])]↔MEMORY[LOCATION(XF)];
RETURN(X);
END;
! construct a new record TRANS, inserted in $YMTAB;
RPTR (SYMBOL) PROCEDURE NEW_TR(STRING SYMB);
BEGIN
REAL ARRAY XF[1:5,1:4];
RPTR(TRANS)VAL;RPTR(SYMBOL)TEMP;
SYMB←NEWSYM(SYMB);
VAL←NEW_RECORD(TRANS); ! creates a new record;
TEMP←ENSYM(SYMB,#TR,VAL); ! enters in $YMTAB;
XF[1,1]←XF[2,2]←XF[3,3]←XF[4,4]←1.0; ! initial values;
! XF[5,4]←1.0;
MEMORY[LOCATION(TRANS:XF[VAL])]↔MEMORY[LOCATION(XF)];
SAVENEW(TEMP,#TR); ! saves (for kill operation);
$TRLST←NULL;
UPDATE; ! updates the display;
RETURN(TEMP);
END;
! symbol table: control,insertion,declcode,killtree,killvar;
RPTR(SYMBOL)PROCEDURE CNVRTR(RPTR(SYMBOL)EL;STRING SYMB);
BEGIN
RPTR(TRANS) TEMP;
TEMP←SYMBOL:OBJECT[EL];
SAVEOLD(EL,#TR);
DELSYM(EL,#TR);
EL←NEW_FR(SYMB);
ARRTRAN(FRAME:XF[SYMBOL:OBJECT[EL]],TRANS:XF[TEMP]);
$FRLST←$TRLST←NULL;
END;
! if the symbol symb is present in $YMTAB in the class OBTYPE returns
the pointer to it, otherwise allows recovering. The symbol is passed
by reference so after recovering the new symbol is sent back;
RANY PROCEDURE BELONGS (REFERENCE STRING SYMB;INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL) EL;
EL←CHECK(SYMB,OBTYPE); ! checks if symbol is present;
WHILE EL=NULL_RECORD
DO BEGIN
IF OBTYPE=#FR
THEN BEGIN
EL←CHECK(SYMB,#TR);
IF EL
THEN BEGIN
EL←CNVRTR(EL,SYMB);
RETURN(SYMBOL:OBJECT[EL]);
END;
END;
PRINT($SEMSG[OBTYPE]);
SYMB←RECOVER(SYMB); ! recover can interrupt the loop and abort;
EL←CHECK(SYMB,OBTYPE);
END;
RETURN(SYMBOL:OBJECT[EL]); ! returns the pointer to the symbol;
END;
! checks if the symbol (scalar,vector or rotation) is in $YMTAB.
If not inserts it, and returns its pointer;
RANY PROCEDURE INSERT(STRING SYMB;INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)EL;
EL←CHECK(SYMB,OBTYPE);
IF EL=NULL_RECORD
THEN CASE OBTYPE OF
BEGIN "CASE"
[#SC] EL←NEW_SC(SYMB);
[#VT] EL←NEW_VT(SYMB);
[#RT] EL←NEW_RT(SYMB);
[#TR] EL←NEW_TR(SYMB)
END "CASE"
ELSE SAVEOLD(EL,OBTYPE); ! old values are saved;
RETURN(SYMBOL:OBJECT[EL]);
END;
! returns the pointer to the frame. If the frame is not present inserts it,
otherwise checks its affixment type and asks for a confirmation if
the affixment type is not independent. In that case recovering is allowed;
RPTR(FRAME) PROCEDURE FR_INSERT (REFERENCE STRING SYMB);
BEGIN "A"
RPTR(SYMBOL) EL;
RPTR(FRAME) FRA; STRING TEMP;INTEGER LINK;
WHILE TRUE
DO BEGIN "LOOP"
EL←CHECK(SYMB,#FR);
IF $LAST=CPY OR $LAST=MRG
THEN WHILE EL≠NULL_RECORD
DO BEGIN
! while copying a new frame is required.
Recovering is allowed if the frame is existent;
PRINT($SEMSG[9]);
SYMB←RECOVER(SYMB);
EL←CHECK(SYMB,#FR);
END;
IF EL=NULL_RECORD
THEN BEGIN
EL←CHECK(SYMB,#TR);
IF EL THEN EL←CNVRTR(EL,SYMB)
ELSE EL←NEW_FR(SYMB); ! defines a new frame;
RETURN(SYMBOL:OBJECT[EL]);
END
ELSE BEGIN "C"
FRA←SYMBOL:OBJECT[EL];
LINK←FRAME:HOWLINKED[FRA];
! changing values of the frame is allowed if link is #INDLK;
IF LINK=#INDLK
THEN BEGIN
SAVEOLD(EL,#FR); ! saves old values;
RETURN(FRA);
END
ELSE BEGIN
! otherwise a confirmation is required;
PRINT(SYMB,
" affixed frame. Changing values can modify the frame tree.",CRLF,
"You can change the name ");
TEMP←RECOVER(SYMB);
! if the name of the frame is the same,
changing values is allowed;
IF EQU(TEMP ,SYMB)
THEN BEGIN
SAVEOLD(EL,#FR); ! saves old values;
RETURN(FRA);
END
ELSE SYMB←TEMP;
END;
END "C";
END "LOOP";
END "A";
! if the symbol symb is present in $YMTAB in the class of the vectors or
of the frames returns its pointer. Recovering is allowed;
RANY PROCEDURE IS_FRVT (REFERENCE STRING SYMB; REFERENCE INTEGER TYPE);
BEGIN
RPTR(SYMBOL) EL;
TYPE←#VT;
EL←CHECK(SYMB,#VT);
WHILE EL=NULL_RECORD
DO BEGIN
EL←CHECK(SYMB,#FR);
IF EL=NULL_RECORD
THEN EL←CHECK(SYMB,#TR)
ELSE BEGIN
TYPE←#FR;
RETURN(SYMBOL:OBJECT[EL]); ! returns the pointer ;
END;
IF EL
THEN BEGIN
EL←CNVRTR(EL,SYMB);
TYPE←#FR;
RETURN(SYMBOL:OBJECT[EL]); ! returns the pointer ;
END
ELSE BEGIN
PRINT($SEMSG[6]);
SYMB←RECOVER(SYMB); ! recover can interrupt the loop and abort;
EL←CHECK(SYMB,#VT);
END;
END;
RETURN(SYMBOL:OBJECT[EL]); ! returns the pointer to the symbol;
END;
! constructs a new trans from 6 values, and returns the pointer to TRANS;
RPTR(TRANS) PROCEDURE DOTREXP(REAL W,PH,TH,X,Y,Z);
BEGIN
RPTR(TRANS) XFE;
XFE←NEW_XFELT;
SET_ROTATION(TRANS:XF[XFE],W,PH,TH);
TRANS:XF[XFE][1,4]←X;
TRANS:XF[XFE][2,4]←Y;
TRANS:XF[XFE][3,4]←Z;
RETURN(XFE);
END;
! constructs a new trans using the rotation and the vector given.
Returns the pointer to the TRANS;
RPTR(TRANS) PROCEDURE DOTR(RPTR(ROT)TMPRT;RPTR(VECTOR)TMPVT);
BEGIN "B"
RPTR(TRANS) XFE;
XFE←NEW_XFELT;
ARRTRAN(TRANS:XF[XFE],ROT:XF[TMPRT]);
TRANS:XF[XFE][1,4]←VECTOR:XC[TMPVT];
TRANS:XF[XFE][2,4]←VECTOR:YC[TMPVT];
TRANS:XF[XFE][3,4]←VECTOR:ZC[TMPVT];
RETURN(XFE);
END "B";
BOOLEAN PROCEDURE PERM(INTEGER I,J);
BEGIN "a"
INTEGER K;
K←(I+1) MOD 3;
IF K=J THEN RETURN(TRUE) ELSE RETURN(FALSE);
END "a";
! constructs a new record TRANS using the three vectors compa,compb,compc:
the first represents the origin of the trans,
the second is on f_axis,
the third is on f_axis - s_axis plane.
The axes are indicated by the numbers xhat=0,yhat=1,zhat=2;
RPTR (TRANS)PROCEDURE VVVTRANS (REAL ARRAY COMPA,COMPB,COMPC;
INTEGER F_AXIS(2),S_AXIS(0));
BEGIN "A"
RPTR(TRANS)XFE;
INTEGER K; OWN REAL ARRAY VI,VK,VJ,VTT[1:3];
! copies the values of array temp in the j column of array TRANS:xf;
PROCEDURE VTCOPY (REAL ARRAY TEMP;INTEGER J);
BEGIN
INTEGER I;
FOR I←1 STEP 1 UNTIL 3 DO
TRANS:XF[XFE][I,J]←TEMP[I];
END;
XFE←NEW_XFELT;
VTCOPY(COMPA,4); ! translation part;
NORMSUB(COMPB,COMPA,VI);
NORMSUB(COMPC,COMPA,VTT);
IF PERM(F_AXIS,S_AXIS)
THEN BEGIN
K←(S_AXIS+1) MOD 3; ! third axis;
NORMCROSS(VI,VTT,VK);
NORMCROSS(VK,VI,VJ);
END
ELSE BEGIN
K←(F_AXIS+1) MOD 3; ! third axis;
NORMCROSS(VTT,VI,VK);
NORMCROSS(VI,VK,VJ);
END;
VTCOPY(VI,F_AXIS+1);
VTCOPY(VK,K+1);
VTCOPY(VJ,S_AXIS+1);
TRANS:XF[XFE][5,4]←0; ! angles not valid;
RETURN(XFE);
END "A";
! constructs a new record entering the symbol in $YMTAB;
PROCEDURE DECLCODE(STRING VAR;INTEGER OBTYPE);
BEGIN
$LAST←DECL; ! for kill instruction;
CASE OBTYPE OF
BEGIN "CASE"
[#SC] NEW_SC(VAR);
[#VT] NEW_VT(VAR);
[#RT] NEW_RT(VAR);
[#FR] NEW_FR(VAR);
[#TR] NEW_TR(VAR)
END "CASE";
END;
! removes from $YMTAB all nodes in the subtrees rooted at el;
RECURSIVE PROCEDURE KILLTREE (RPTR(SYMBOL) EL);
BEGIN
RPTR(FRAME)TEMP;
TEMP←SYMBOL:OBJECT[EL];
DELSYM(EL,#FR); ! removes el from $YMTAB;
TEMP←FRAME:SON[TEMP];
WHILE TEMP≠NULL_RECORD DO
BEGIN
EL←CHECK(FRAME:PNAME[TEMP],#FR);
SAVEOLD(EL,#FR); ! saves the values;
KILLTREE(EL);
TEMP←FRAME:EBRO[TEMP];
END;
END;
! removes the symbol from $YMTAB;
PROCEDURE KILLVAR(REFERENCE STRING VAR);
BEGIN
RPTR (SYMBOL) EL;RPTR(FRAME)D;INTEGER OBTYPE;
$LAST←DEL; ! for kill instruction;
EL←OLDSYM(VAR,OBTYPE);
IF EL=F_FID THEN F_FID←NULL_RECORD
ELSE IF EL=F_POINTER THEN F_POINTER←ARM←NULL_RECORD;
IF OBTYPE≠#FR
THEN BEGIN
SAVEOLD(EL,OBTYPE); ! saves values;
DELSYM(EL,OBTYPE);
$SCLST←$VTLST←$RTLST←NULL;
END
ELSE BEGIN
RPTR(FRAME) TEMP;
TEMP←SYMBOL:OBJECT[EL];
SAVETREE(FRAME:PNAME[TEMP]); ! saves the tree;
UNLNK_NODE(TEMP); ! unfixes the frame;
KILLTREE(EL); ! deletes subtrees rooted in var;
END;
UPDATE;
END;
FORWARD PROCEDURE AFX_NODE(RPTR(FRAME)N,D;INTEGER HOW);
FORWARD PROCEDURE UFX_NODE(RPTR(FRAME)N,D);
! the procedure deletes all the variables defined by the user;
PROCEDURE RESET;
BEGIN
INTEGER IND,I;INTEGER ARRAY SAVE[0:4];
$LAST←0; ! unkillable instruction;
SAVE[0]←2; ! 2 scalars predefined in the system;
SAVE[1]←4; ! 4 vectors;
SAVE[2]←1; ! 1 rotation;
SAVE[3]←7; ! 7 frames;
SAVE[4]←1; ! 1 trans;
FOR IND←0 STEP 1 UNTIL 3 DO
BEGIN ! IND=0 for #SC,=1 for #VT,=2 for #RT, =3 for #FR;
! deletes the records defined for each type;
FOR I←#LTYPE*IND+SAVE[IND] STEP 1 UNTIL $ENTRY[IND]-1 DO
$YMTAB[I]←NULL_RECORD;
$ENTRY[IND]←#LTYPE*IND+SAVE[IND]; ! remembers the new $ENTRY to $YMTAB;
END;
! updates the frame tree structure;
F_FID←NULL_RECORD;
UFX_NODE(F_BGRASP,F_WORLD);
UFX_NODE(F_BARM,F_WORLD);
UFX_NODE(F_YARM,F_WORLD);
UFX_NODE(F_POINTER,F_WORLD);
UFX_NODE(F_BPARK,F_WORLD);
UFX_NODE(F_YPARK,F_WORLD);
! FRAME:SON[F_BARM]←FRAME:SON[F_YARM]←NULL_RECORD;
$ALLOW←$ALLOW+1;
AFX_NODE(F_BARM,F_WORLD,#NRGLK);
AFX_NODE(F_YARM,F_WORLD,#NRGLK);
AFX_NODE(F_BGRASP,F_BARM,#RGDLK);
AFX_NODE(F_POINTER,F_BARM,#RGDLK);
! FRAME:EBRO[F_BARM]←NULL_RECORD;
$ALLOW←$ALLOW-1;
$SCLST←$VTLST←$RTLST←$FRLST←$TRLST←NULL;
UPDATE;
END;
! arithmetic: absxf, setabsxf, absset, relset, absloc, relloc,copyrtfr,copyvtfr;
! sets up xf to be the location of N in the WORLD;
PROCEDURE ABSXF(RPTR(FRAME) N;REAL ARRAY XF);
BEGIN
ARRTRAN(XF,FRAME:XF[N]); ! xf ← frame:xf[N];
WHILE FRAME:HOWLINKED[N]≠#INDLK DO
BEGIN
OWN REAL ARRAY XFTMP[1:5,1:4];
N←FRAME:DAD[N];
IF N=NULL_RECORD
THEN ABORT1(" ",$SEMSG[5]);
XFXFMUL(FRAME:XF[N],XF,XFTMP); ! xftmp ← xf[n]*xf;
ARRTRAN(XF,XFTMP); ! xf ← xftmp;
END;
END;
! sets up link transforms so that ABSXF(N)=XF.
(If rigid affixments, will move parents);
PROCEDURE SETABSXF(RPTR(FRAME) N;REAL ARRAY XF);
BEGIN
OWN REAL ARRAY XFTMP,XFTMP2,XFTMP3[1:5,1:4];
RPTR(SYMBOL)EL;RPTR(FRAME) TEMP;
TEMP←N;
ARRTRAN(XFTMP,XF); ! xftmp←xf;
WHILE FRAME:HOWLINKED[N]=#RGDLK DO
BEGIN
XFINVRT(frame:XF[N],XFTMP3);
XFXFMUL(XFTMP,XFTMP3,XFTMP2);
ARRTRAN(XFTMP,XFTMP2); ! xftmp←xftmp*inv(xf[n]);
N←FRAME:DAD[N];
END;
IF TEMP≠N
THEN BEGIN
! if there are some #RGDLK, finds the pointer to the first frame
not rigidly affixed, and saves its values;
EL←CHECK(FRAME:PNAME[N],#FR);
SAVEOLD(EL,#FR);
END;
IF FRAME:HOWLINKED[N]=#INDLK
THEN ARRTRAN(FRAME:XF[N],XFTMP)
ELSE BEGIN
! xftmp2 gets the absolute value of dad of N;
ABSXF(FRAME:DAD[N],XFTMP2);
! frame:xf[n]←inv(xftmp2)*xftmp;
INVXFXF(XFTMP2,XFTMP,FRAME:XF[N]);
END;
END;
! sets the relative value of the frame to the value of TRANS;
PROCEDURE RELSET(RPTR(FRAME)FRA;RPTR(TRANS)XFE);
BEGIN
ARRTRAN(FRAME:XF[FRA],TRANS:XF[XFE]);
END;
! sets the absolute value to the frame to be the value of TRANS;
PROCEDURE ABSSET(RPTR(FRAME) FRA;RPTR(TRANS)XFE);
BEGIN
SETABSXF(FRA,TRANS:XF[XFE]);
END;
! returns a TRANS with the relative position of the frame;
RPTR(TRANS) PROCEDURE RELLOC(RPTR(FRAME)ND);
BEGIN
RPTR(TRANS) XFE;
XFE←NEW_XFELT;
ARRTRAN(TRANS:XF[XFE],FRAME:XF[ND]);
RETURN(XFE);
END;
! returns a TRANS with the absolute value of the frame;
RPTR(TRANS) PROCEDURE ABSLOC(RPTR(FRAME) ND);
BEGIN
RPTR(TRANS) XFE;
XFE←NEW_XFELT;
ABSXF(ND,TRANS:XF[XFE]);
RETURN (XFE);
END;
! returns in the record rot the rotation part of the frame sec;
PROCEDURE COPYRTFR(RPTR(ROT)FIRST;RPTR(FRAME)SEC);
BEGIN
RPTR(TRANS) XFE;
XFE←ABSLOC(SEC);
ARRTRAN(ROT:XF[FIRST],TRANS:XF[XFE]);
ROT:XF[FIRST][1,4]←ROT:XF[FIRST][2,4]←ROT:XF[FIRST][3,4]←0.;
END;
! returns in the record vector the location part of the frame sec;
PROCEDURE COPYVTFR(RPTR(VECTOR)FIRST;RPTR(FRAME)SEC);
BEGIN
RPTR(TRANS) XFE;
XFE←ABSLOC(SEC); ! absolute value of the frame;
VECTOR:XC[FIRST]←TRANS:XF[XFE][1,4];
VECTOR:YC[FIRST]←TRANS:XF[XFE][2,4];
VECTOR:ZC[FIRST]←TRANS:XF[XFE][3,4];
END;
! arith. operations: opscal,opscvt,opdot,opvet,oprtrt,oprtvt,opfrvt,mulrtrt;
! this is for scalar assignment instructions:
el ← num1 op num2
where op is the operator, num1,num2 are real numbers, el is a scalar;
PROCEDURE OPSCAL(REAL NUM1,NUM2;RPTR(SCALAR)EL;STRING OP);
BEGIN
REAL RESULT;
IF OP="+"
THEN RESULT← NUM1+NUM2
ELSE IF OP="-"
THEN RESULT←NUM1-NUM2
ELSE IF OP="*"
THEN RESULT←NUM1*NUM2
ELSE RESULT←NUM1/NUM2 ;
SCALAR:VALUE[EL]←RESULT;
END;
! this is for vector assignment instruction:
valf ← val op num,
where op is the operator, num is a scalar, val,valf are vectors;
PROCEDURE OPSCVT(REAL NUM;RPTR(VECTOR)VAL,VALF;STRING OP);
BEGIN
IF OP="*"
THEN BEGIN
VECTOR:XC[VALF]←VECTOR:XC[VAL]*NUM;
VECTOR:YC[VALF]←VECTOR:YC[VAL]*NUM;
VECTOR:ZC[VALF]←VECTOR:ZC[VAL]*NUM;
END
ELSE BEGIN
VECTOR:XC[VALF]←VECTOR:XC[VAL]/NUM;
VECTOR:YC[VALF]←VECTOR:YC[VAL]/NUM;
VECTOR:ZC[VALF]←VECTOR:ZC[VAL]/NUM;
END;
END;
! this is for the dot product operation:
valf←val1.val2
where valf is the scalar, val1,val2 are vectors;
PROCEDURE OPDOT(RPTR(VECTOR)VAL1,VAL2;RPTR(SCALAR) VALF);
BEGIN
REAL TEMP;
TEMP←VECTOR:XC[VAL1]*VECTOR:XC[VAL2]+
VECTOR:YC[VAL1]*VECTOR:YC[VAL2]+
VECTOR:ZC[VAL1]*VECTOR:ZC[VAL2];
SCALAR:VALUE[VALF]←TEMP;
END;
! this is for vector assignment operation:
valf ← val1 op val2
where val1,val2,valf are vectors and op is the operator;
PROCEDURE OPVET(RPTR(VECTOR) VAL1,VAL2,VALF;STRING OP);
BEGIN
IF OP="+"
THEN BEGIN
VECTOR:XC[VALF]←VECTOR:XC[VAL1]+VECTOR:XC[VAL2];
VECTOR:YC[VALF]←VECTOR:YC[VAL1]+VECTOR:YC[VAL2];
VECTOR:ZC[VALF]←VECTOR:ZC[VAL1]+VECTOR:ZC[VAL2];
END
ELSE BEGIN
VECTOR:XC[VALF]←VECTOR:XC[VAL1]-VECTOR:XC[VAL2];
VECTOR:YC[VALF]←VECTOR:YC[VAL1]-VECTOR:YC[VAL2];
VECTOR:ZC[VALF]←VECTOR:ZC[VAL1]-VECTOR:ZC[VAL2];
END;
END;
! this is for rotation assignment operation:
valf ← val1 * val2
where val1,val2,valf are rotations;
PROCEDURE OPRTRT(RPTR(ROT)VAL1,VAL2,VALF);
BEGIN
XFXFMUL(ROT:XF[VAL1],ROT:XF[VAL2],ROT:XF[VALF]);
END;
! this is for product of a vector and a rotation:
valf ← val1 * val2
where val2,valf are vectors and val1 is a rotation;
PROCEDURE OPRTVT(RPTR(ROT)VAL1;RPTR(VECTOR)VAL2,VALF);
BEGIN
REAL ARRAY COMPF,COMP2[1:3];
GETVTVAL(VAL2,COMP2);
XFVTMUL(ROT:XF[VAL1],COMP2,COMPF);
PUTVTVAL(VALF,COMPF);
END;
! this is for frame translations:
valf ← val1 op val2 (commutative)
where valf,val2 are frames, val1 is a vector and op is the operator;
PROCEDURE OPFRVT(RPTR(VECTOR) VAL1;RPTR(FRAME)VAL2,VALF;STRING OP);
BEGIN
REAL ARRAY FXF[1:5,1:4];
ABSXF(VAL2,FXF);
SETABSXF(VALF,FXF);
IF OP="+"
THEN BEGIN
FRAME:XF[VALF][1,4]←FRAME:XF[VALF][1,4]+VECTOR:XC[VAL1];
FRAME:XF[VALF][2,4]←FRAME:XF[VALF][2,4]+VECTOR:YC[VAL1];
FRAME:XF[VALF][3,4]←FRAME:XF[VALF][3,4]+VECTOR:ZC[VAL1];
END
ELSE BEGIN
FRAME:XF[VALF][1,4]←FRAME:XF[VALF][1,4]-VECTOR:XC[VAL1];
FRAME:XF[VALF][2,4]←FRAME:XF[VALF][2,4]-VECTOR:YC[VAL1];
FRAME:XF[VALF][3,4]←FRAME:XF[VALF][3,4]-VECTOR:ZC[VAL1];
END;
END;
! this is to compute a vector when its origin is translated into
the frame (equivalent to valf← val2 REL val1)
valf←val1*val2
where val1 is a frame, val2 and valf are vectors;
PROCEDURE OPVTFR(RPTR(FRAME) VAL1;RPTR(VECTOR)VAL2,VALF);
BEGIN
REAL ARRAY COMP2,COMPF[1:3];REAL ARRAY FXF[1:5,1:4];
ABSXF(VAL1,FXF);
GETVTVAL(VAL2,COMP2);
XFVTMUL(FXF,COMP2,COMPF);
PUTVTVAL(VALF,COMPF);
END;
! computes <vector>←<trans>*<vector>;
PROCEDURE OPTRVT(RPTR(TRANS)VAL1;RPTR(VECTOR)VAL2,VALF);
BEGIN
REAL ARRAY COMP2,COMPF[1:3];REAL ARRAY FXF[1:5,1:4];
GETVTVAL(VAL2,COMP2);
ARRTRAN(FXF,TRANS:XF[VAL1]);
XFVTMUL(FXF,COMP2,COMPF);
PUTVTVAL(VALF,COMPF);
END;
! computes <trans>←<frame>→<frame>;
PROCEDURE OPFRFR(RPTR(FRAME)VAL1,VAL2;RPTR(TRANS)VALF);
BEGIN
RPTR(TRANS) TEMP1,TEMP2;
TEMP1←ABSLOC(VAL1);
TEMP2←ABSLOC(VAL2);
INVXFXF(TRANS:XF[TEMP1],TRANS:XF[TEMP2],TRANS:XF[VALF]);
END;
! computes <trans>←<trans>*<trans>;
PROCEDURE OPTRTR(RPTR(TRANS)VAL1,VAL2,VALF);
BEGIN
XFXFMUL(TRANS:XF[VAL1],TRANS:XF[VAL2],TRANS:XF[VALF]);
END;
! computes <frame>← <trans>*<frame>;
PROCEDURE OPTRFR(RPTR(TRANS)VAL1;RPTR(FRAME)VAL2,VALF);
BEGIN
OWN REAL ARRAY FTEMP,FTEMP2[1:5,1:4];
ABSXF(VAL2,FTEMP); ! computes absolute value of val2;
XFXFMUL(TRANS:XF[VAL1],FTEMP,FTEMP2); ! ftemp2 abs.pos. of valf;
SETABSXF(VALF,FTEMP2); ! sets abs.pos of valf to ftemp2;
END;
! computes <frame>←<frame>*<frame>;
PROCEDURE OPFR(RPTR(FRAME)VAL1,VAL2,VALF);
BEGIN
RPTR(TRANS)TEMP;
TEMP←ABSLOC(VAL1);
OPTRFR(TEMP,VAL2,VALF);
END;
! returns a rotation obtained by multiplying the two given rotations;
RPTR(ROT)PROCEDURE MULRTRT(RPTR(ROT)R1,R2);
BEGIN
RPTR(ROT) TEMPF;REAL ARRAY A[1:5,1:4];
TEMPF←NEW_RECORD(ROT);
MEMORY[LOCATION(A)]↔MEMORY[LOCATION(ROT:XF[TEMPF])];
OPRTRT(R1,R2,TEMPF);
RETURN(TEMPF);
END;
! arith. operations: asgcode,absvtcomp,relvtcomp,expfrcode,expvtcode;
! assigns to first the value of ob2. If first has not been declared
the procedure determines the type of first, according to the value
of obtype: obtype is #MX when a TRANS is used to transfer the
values (explicit frame assignment);
PROCEDURE ASGEXP(STRING FIRST; RANY OB2;INTEGER OBTYPE);
BEGIN
RANY OB1;
$LAST←ASG; ! used by kill;
$ALLOW←$ALLOW+1; ! to avoid updating display;
CASE OBTYPE OF
BEGIN
[#SC] BEGIN
OB1←INSERT(FIRST,OBTYPE); ! inserts in $YMTAB,if not inserted;
SCALAR:VALUE[OB1]←SCALAR:VALUE[OB2];
END;
[#VT] BEGIN
OB1←INSERT(FIRST,OBTYPE); ! inserts in $YMTAB,if not inserted;
VECTOR:XC[OB1]←VECTOR:XC[OB2];
VECTOR:YC[OB1]←VECTOR:YC[OB2];
VECTOR:ZC[OB1]←VECTOR:ZC[OB2];
END;
[#RT] BEGIN
OB1←INSERT(FIRST,OBTYPE); ! inserts in $YMTAB,if not inserted;
ARRTRAN(ROT:XF[OB1],ROT:XF[OB2]);
END;
[#TR] BEGIN
OB1←INSERT(FIRST,OBTYPE);
ARRTRAN(TRANS:XF[OB1],TRANS:XF[OB2]);
END;
[#MX] BEGIN
END;
[#FR] BEGIN
REAL ARRAY FXF[1:5,1:4];
OB1←FR_INSERT(FIRST); ! inserts in $YMTAB,if not inserted;
ABSXF(OB2,FXF);
SETABSXF(OB1,FXF);
END
END;
$ALLOW←$ALLOW-1; ! for display;
UPDATE;
END;
! simple assignement: assigns to first the value of arg. Type indicates
if arg is a number or an identifier;
PROCEDURE ASGCODE(STRING FIRST,ARG;INTEGER TYPE);
BEGIN
RPTR(SYMBOL)EL2; RANY OBJ;
INTEGER OBTYPE,BR;REAL TEMP;
$LAST←ASG; ! for kill instruction;
IF TYPE=#INT OR TYPE=#FLN
THEN BEGIN
$ALLOW←$ALLOW+1;
OBJ←INSERT(FIRST,#SC); ! first must be a scalar;
TEMP←REALSCAN(ARG,BR); ! so temp is a real number;
SCALAR:VALUE[OBJ]←TEMP; ! assigns value to first;
$ALLOW←$ALLOW-1;
UPDATE;
END
ELSE BEGIN
EL2←OLDSYM(ARG,OBTYPE);
OBJ←SYMBOL:OBJECT[EL2];
ASGEXP(FIRST,OBJ,OBTYPE); ! assigns value to first;
END;
END;
! if type=#VT computes POS, by extracting the location part of the frame
fra and assigning it to the vector first, otherwise
computes ORIENT, by extracting the orientation part of the frame
fra and assigning it to the rotation first;
PROCEDURE VTRTCODE(STRING FIRST,FRA;INTEGER TYPE);
BEGIN
RANY RESULT;RPTR(FRAME) EL;
$LAST←ASG; ! used by kill instruction;
$ALLOW←$ALLOW+1;
EL←BELONGS (FRA,#FR); ! fra must be a frame;
IF TYPE=#VT
THEN BEGIN
RESULT←INSERT(FIRST,#VT); ! inserts in $YMTAB,if not inserted;
COPYVTFR(RESULT,EL); ! takes the location part of FRA;
END
ELSE BEGIN
RESULT←INSERT(FIRST,#RT); ! inserts in $YMTAB,if not inserted;
COPYRTFR(RESULT,EL); ! takes the orientation part of FRA;
END;
$ALLOW←$ALLOW-1;
UPDATE;
END;
! computes the product of a frame by a vector(used for REL operation);
PROCEDURE RELVTC(REAL ARRAY COMP,RESULT;RPTR(FRAME) RELF);
BEGIN
OWN REAL ARRAY FXF[1:5,1:4];
ABSXF(RELF,FXF); ! takes absolute value of frame;
XFVTMUL(FXF,COMP,RESULT); ! multiplies: result in RESULT;
END;
! computes the WRT operation on a vector;
PROCEDURE WRTVTC(REAL ARRAY COMP,RESULT;RPTR(FRAME)RELF);
BEGIN
REAL ARRAY FXF,XFX[1:5,1:4];
ABSXF(RELF,FXF); ! absolute value of the frame;
XFVTMUL(FXF,COMP,RESULT); ! multiplies frame by vector;
RESULT[1]←RESULT[1]-FXF[1,4]; ! subtracts the traslation;
RESULT[2]←RESULT[2]-FXF[2,4];
RESULT[3]←RESULT[3]-FXF[3,4];
END;
! explicit assignment of values to a vector wrt/rel a frame;
PROCEDURE ASGVTEXP(STRING FIRST; RPTR(VECTOR)SEC;STRING OP,RELFR);
BEGIN
RPTR(FRAME) REL;RPTR(VECTOR) NEWVT;OWN REAL ARRAY ABSVT,RELVT[1:3];
$LAST←ASG; ! for kill instruction;
$ALLOW←$ALLOW+1;
IF EQU(RELFR,"STATION")
THEN ASGEXP(FIRST,SEC,#VT)
ELSE BEGIN
REL←BELONGS (RELFR,#FR); ! relfr must be a frame;
NEWVT←INSERT(FIRST,#VT); ! inserts the vector,if not existent;
GETVTVAL(SEC,ABSVT);
IF EQU(OP,"WRT")
THEN WRTVTC(ABSVT,RELVT,REL)
ELSE RELVTC(ABSVT,RELVT,REL); ! REL operation;
PUTVTVAL(NEWVT,RELVT); ! assigns to the vector its values;
END;
$ALLOW←$ALLOW-1;
UPDATE;
END;
! explicit assignment of values to the frame first. Values can be
relative to relframe;
PROCEDURE ASGFREXP(STRING FIRST;RPTR(TRANS)XFE;STRING RELFRAME);
BEGIN
RPTR(FRAME) RELF,FRN;
$LAST←ASG;
$ALLOW←$ALLOW+1;
FRN←FR_INSERT(FIRST); ! inserts the frame,if not existent;
IF RELFRAME
THEN BEGIN
RELF←BELONGS (RELFRAME,#FR); ! relframe must be a frame;
IF RELF=F_WORLD
THEN ARRTRAN(FRAME:XF[FRN],TRANS:XF[XFE])
ELSE BEGIN
OWN REAL ARRAY FTEMP,FTEMP2[1:5,1:4];
ABSXF(RELF,FTEMP); ! computes absolute value of relf;
XFXFMUL(FTEMP,TRANS:XF[XFE],FTEMP2); ! ftemp2 abs.pos. of frn;
SETABSXF(FRN,FTEMP2); ! sets abs.pos of frn to ftemp2;
END;
END
ELSE ARRTRAN(FRAME:XF[FRN],TRANS:XF[XFE]);
$ALLOW←$ALLOW-1;
UPDATE;
END;
! assigns to the vector first the value of second, after performing
the operation (WRT/REL) indicated by op;
PROCEDURE ASGVTFR(STRING FIRST,SEC,OP,RELFR);
BEGIN
RANY EL;INTEGER TYPE;
EL←IS_FRVT(SEC,TYPE);
IF TYPE=#VT
THEN ASGVTEXP(FIRST,EL,OP,RELFR)
ELSE IF EQU(OP,"REL")
THEN ASGFREXP(FIRST,ABSLOC(EL),RELFR)
ELSE ABORT($SYNMSG[12],$SYNMSG[25]);
END;
! arith. operations: arithcode,constrcode,unitcode,axiscode;
! assigns to first the value of arg1 op arg1, where op is an arithmetic
operator;
PROCEDURE ARITHCODE(STRING FIRST,ARG1,OP,ARG2;INTEGER TYPE1,TYPE2);
BEGIN
RANY VAL1,VAL2,VALF;RPTR(SYMBOL)EL1,EL2;RPTR(FRAME)RELF;
REAL NUM1,NUM2;
INTEGER OBTP1,OBTP2,OBTPF,BR;
$LAST←ASG; ! for kill instruction;
$ALLOW←$ALLOW+1; ! avoids updating display;
IF TYPE1 = #IDF
THEN BEGIN
EL1←OLDSYM(ARG1,OBTP1); ! checks if arg1 exists;
VAL1←SYMBOL:OBJECT[EL1]; ! val1=pointer to the record;
! if arg1 is a scalar takes its value;
IF OBTP1=#SC
THEN NUM1←SCALAR:VALUE[VAL1] ;
END
ELSE BEGIN
! if arg1 is a number takes its value and assigns the type to obtp1;
OBTP1←#SC;
NUM1←REALSCAN(ARG1,BR); ! num1=value of arg1;
END;
IF TYPE2=#IDF
THEN BEGIN
EL2←OLDSYM(ARG2,OBTP2); ! checks if arg2 exists;
VAL2←SYMBOL:OBJECT[EL2]; ! val2=pointer to the record;
! if arg2 is a scalar takes its value;
IF OBTP2=#SC
THEN NUM2←SCALAR:VALUE[VAL2];
END
ELSE BEGIN
! if arg2 is a number takes its value and assigns the type to obtp2;
OBTP2←#SC;
NUM2←REALSCAN(ARG2,BR); ! num2=value of arg2;
END;
IF OBTP1=#SC
THEN IF OBTP2=#SC
THEN BEGIN
VALF←INSERT(FIRST,#SC); ! result must be a scalar;
OPSCAL(NUM1,NUM2,VALF,OP); ! operation on scalars;
END
ELSE IF OBTP2=#VT AND OP="*"
THEN BEGIN
VALF←INSERT(FIRST,#VT); ! result must be a vector;
OPSCVT(NUM1,VAL2,VALF,OP); ! product scalar*vector;
END
ELSE ABORT1(" ",$SEMSG[10]); ! incorrect types;
IF OBTP1=#VT
THEN IF OBTP2=#SC
THEN IF OP="/" OR OP="*"
THEN BEGIN
VALF←INSERT(FIRST,#VT); ! result must be a vector;
OPSCVT(NUM2,VAL1,VALF,OP); ! operation on scalar&vector;
END
ELSE ABORT1(" ",$SEMSG[10])
ELSE IF OBTP2=#VT
THEN IF OP="."
THEN BEGIN
VALF←INSERT(FIRST,#SC); ! result must be a scalar;
OPDOT(VAL1,VAL2,VALF); ! dot product;
END
ELSE IF OP="+" OR OP="-"
THEN BEGIN
VALF←INSERT(FIRST,#VT); ! result must be a vector;
OPVET(VAL1,VAL2,VALF,OP);
END
ELSE ABORT1 (" ",$SEMSG[10])
ELSE IF OBTP2=#FR
THEN IF OP="+" OR OP="-"
THEN BEGIN
VALF←FR_INSERT(FIRST); ! result must be a frame;
OPFRVT(VAL1,VAL2,VALF,OP); ! translation of a frame;
END
ELSE ABORT1(" ",$SEMSG[10]); ! incorrect types;
IF OBTP1=#RT
THEN IF OBTP2=#RT AND OP="*"
THEN BEGIN
VALF←INSERT(FIRST,#RT); ! result must be a rot;
OPRTRT(VAL1,VAL2,VALF); ! product of rot;
END
ELSE IF OBTP2=#VT AND OP="*"
THEN BEGIN
VALF←INSERT(FIRST,#VT); ! result must be a vector;
OPRTVT(VAL1,VAL2,VALF); ! rotation of a vector;
END
ELSE ABORT1(" ",$SEMSG[10]); ! incorrect types;
IF OBTP1=#TR
THEN IF OBTP2=#VT AND OP ="*"
THEN BEGIN
VALF←INSERT(FIRST,#VT);
OPTRVT(VAL1,VAL2,VALF);
END
ELSE IF OBTP2=#TR AND OP="*"
THEN BEGIN
VALF←INSERT(FIRST,#TR);
OPTRTR(VAL1,VAL2,VALF);
END
ELSE IF OBTP2=#FR AND OP="*"
THEN BEGIN
VALF←FR_INSERT(FIRST);
OPTRFR(VAL1,VAL2,VALF);
END
ELSE ABORT1(" ",$SEMSG[10]);
IF OBTP1=#FR
THEN IF OBTP2=#VT
THEN IF OP="+" OR OP="-"
THEN BEGIN
VALF←FR_INSERT(FIRST); ! result must be a frame;
OPFRVT(VAL2,VAL1,VALF,OP); ! translation of a frame;
END
ELSE IF OP="*"
THEN BEGIN
VALF←INSERT(FIRST,#VT); ! result must be a vector;
OPVTFR(VAL1,VAL2,VALF); ! operation on frame&vector;
END
ELSE ABORT1(" ",$SEMSG[10])
ELSE IF OBTP2=#FR
THEN IF OP="→"
THEN BEGIN
VALF←INSERT(FIRST,#TR);
OPFRFR(VAL1,VAL2,VALF);
END
ELSE IF OP="*"
THEN BEGIN
VALF←FR_INSERT(FIRST);
OPFR(VAL1,VAL2,VALF);
END
ELSE ABORT1(" ",$SEMSG[10])
ELSE ABORT1(" ",$SEMSG[10]);
$SCLST←$VTLST←$RTLST←$FRLST←$TRLST←NULL;
$ALLOW←$ALLOW-1;
UPDATE;
END;
! constructs a new frame using the location part of the three frames
or the three vectors: the first is at the origin, the second on z_axis
and the third on z_x plane;
PROCEDURE CONSTRCODE(STRING FST,FR1,FR2,FR3);
BEGIN
RANY ELF;RPTR(TRANS) XFEF;
OWN REAL ARRAY COMP1,COMP2,COMP3[1:3];
! puts the three components of the vector or the translation part of the
frame in the array comp;
PROCEDURE GETVET(STRING NAME;REAL ARRAY COMP);
BEGIN
RANY EL; INTEGER TYPE;RPTR(TRANS) XFE;
EL←IS_FRVT(NAME,TYPE); ! must be vector or frame;
IF TYPE=#FR
THEN BEGIN
XFE←ABSLOC(EL); ! computes absolute value;
GETVTTR(XFE,COMP); ! puts transl.part in array;
END
ELSE GETVTVAL(EL,COMP); ! puts vector value in array;
END;
$LAST←ASG; ! for kill instruction;
$ALLOW←$ALLOW+1;
GETVET(FR1,COMP1);
GETVET(FR2,COMP2);
GETVET(FR3,COMP3);
XFEF←VVVTRANS(COMP1,COMP2,COMP3); ! constructs a new trans;
ELF←FR_INSERT(FST); ! inserts fst in frame class;
ABSSET(ELF,XFEF); ! sets value of frame;
$ALLOW←$ALLOW-1;
UPDATE;
END;
PROCEDURE UNITCODE(STRING FIRST;RPTR(VECTOR)OB2);
BEGIN "a"
RPTR(VECTOR)OB1;REAL ARRAY COMP[1:3];
$LAST←ASG;
$ALLOW←$ALLOW+1;
OB1←INSERT(FIRST,#VT);
GETVTVAL(OB2,COMP);
NORM(COMP);
PUTVTVAL(OB1,COMP);
$ALLOW←$ALLOW-1;
$VTLST←NULL;
UPDATE;
END "a";
PROCEDURE AXISCODE(STRING FIRST;RPTR(ROT) COMP);
BEGIN
PRINT(#SORRY);
END;
PROCEDURE MODRT(STRING FIRST;RPTR(ROT)SEC);
BEGIN
PRINT(#SORRY);
END;
PROCEDURE MODSC(STRING FIRST;RPTR(SCALAR)SEC);
BEGIN
RPTR(SCALAR) FST;
$ALLOW←$ALLOW-1;
FST←INSERT(FIRST,#SC);
SCALAR:VALUE[FST]←ABS(SCALAR:VALUE[SEC]);
$SCLST←NULL;
$ALLOW←$ALLOW+1;
UPDATE;
END;
PROCEDURE MODVT(STRING FIRST;RPTR(VECTOR)SEC);
BEGIN
RPTR(SCALAR) FST;REAL M;
$ALLOW←$ALLOW-1;
FST←INSERT(FIRST,#SC);
M←SQRT(VECTOR:XC[SEC]↑2+VECTOR:YC[SEC]↑2+VECTOR:ZC[SEC]↑2);
IF M≤$EPS THEN ABORT1("NORM NOT WELL DEFINED"," ");
SCALAR:VALUE[FST]←M;
$SCLST←NULL;
$ALLOW←$ALLOW+1;
UPDATE;
END;
! tree operations: affixcode,unfixcode (afx_node);
! affixes the frame pointed by n to the frame pointed by d, as indicated
by how;
PROCEDURE AFX_NODE(RPTR(FRAME)N,D;INTEGER HOW);
BEGIN
OWN REAL ARRAY XFTMP1,XFTMP2[1:5,1:4];
IF HOW=#INDLK
THEN ABSXF(N,FRAME:XF[N])
ELSE BEGIN ! xf[n]←inv(absxf[d])*absxf[n];
ABSXF(D,XFTMP2);
XFINVRT(XFTMP2,XFTMP1);
ABSXF(N,XFTMP2);
XFXFMUL(XFTMP1,XFTMP2,FRAME:XF[N]);
END;
LNK_NODE(N,D); ! sets links in frame tree;
FRAME:HOWLINKED[N]←HOW;
UPDATE;
END;
PROCEDURE UFX_NODE(RPTR(FRAME)EL1,EL2);
BEGIN
OWN REAL ARRAY FXF[1:5,1:4];
ABSXF(EL1,FXF); ! fxf=absolute value of frame1;
ARRTRAN(FRAME:XF[EL1],FXF); ! assigns absolute value to frame;
UNLNK_NODE(EL1); ! breaks links in tree;
FRAME:HOWLINKED[EL1]←#INDLK;
LNK_NODE(EL1,F_WORLD); ! sets new links;
END;
! affixes frame1 to frame2, as indicated by afftype;
PROCEDURE AFFIXCODE(STRING FRAME1,FRAME2; INTEGER AFFTYPE);
BEGIN
RPTR(FRAME) N,D;
$LAST←AFX; ! for kill instruction;
D←BELONGS (FRAME2,#FR); ! frame2 must be a frame;
N←BELONGS (FRAME1,#FR); ! frame1 must be a frame;
SAVETREE(FRAME1); ! saves tree for kill instruction;
AFX_NODE(N,D,AFFTYPE); ! affixes n to d;
END;
! unfixes frame1 and affixes it independently to world;
PROCEDURE UNFIXCODE(STRING FRAME1,FRAME2);
BEGIN
RPTR(FRAME)EL1,EL2;
$LAST←AFX; ! for kill instruction;
EL1←BELONGS (FRAME1,#FR); ! frame1 must be a frame;
EL2←BELONGS (FRAME2,#FR); ! frame2 must be a frame;
IF EL2≠F_WORLD
THEN
WHILE FRAME:DAD[EL1]≠EL2
DO BEGIN
PRINT(FRAME2," is not the dad of ",FRAME1," Try again ");
FRAME2←RECOVER(FRAME2);
EL2←BELONGS(FRAME2,#FR);
END;
SAVETREE(FRAME1); ! saves tree for kill instruction;
UFX_NODE(EL1,EL2);
UPDATE;
END;
! tree operations: copycode,copy,copy_tree;
! copies the subtree rooted at startfr and affixes it to finalfr.
Prefix is used to build the names of the new frames;
PROCEDURE PCOPY(RPTR(FRAME) STARTFR,FINALFR; STRING PREFIX);
BEGIN
OWN REAL ARRAY FXF[1:5,1:4];INTEGER LINK;RPTR(FRAME)ROOT;
RPTR(FRAME) RECURSIVE PROCEDURE COPY_TREE(RPTR(FRAME) ND);
BEGIN
! copies the structure rooted at ND. Leaves copy (NND)
affixed to DAD[ND];
RPTR(FRAME) NND,KIDS;
STRING OLDNAME,LEAVE,NEWNAME;
OLDNAME←FRAME:PNAME[ND];
! constructs the new name of the frame: if the name of the copied
frame contains an underscore, the part before it is substituted
by prefix, otherwise prefix is prefixed;
LEAVE←SCAN(OLDNAME,$DSHTAB,$BRCHR);
IF $BRCHR≠0
THEN NEWNAME←PREFIX&OLDNAME
ELSE NEWNAME←PREFIX&LEAVE;
NND←FR_INSERT(NEWNAME); ! inserts a new frame;
comment PRINT("new frame ",newname,crlf);
ARRTRAN(FRAME:XF[NND],FRAME:XF[ND]);
FRAME:HOWLINKED[NND]←FRAME:HOWLINKED[ND];
KIDS←FRAME:SON[ND];
WHILE KIDS≠NULL_RECORD DO
BEGIN
comment PRINT("SON ",FRAME:PNAME[KIDS],CRLF);
LNK_NODE(COPY_TREE(KIDS),NND);
KIDS←FRAME:EBRO[KIDS];
comment PRINT("EBRO ",FRAME:PNAME[KIDS],CRLF);
END;
RETURN(NND);
END;
ROOT←COPY_TREE(STARTFR); ! copies the subtree;
LNK_NODE(ROOT,FINALFR); ! sets new links;
UPDATE;
END;
! merges the subtrees under startfr as sons of finalfr. Prefix is
used to build the names of new frames;
PROCEDURE PMERGE(RPTR(FRAME) STARTFR,FINALFR;STRING PREFIX);
BEGIN
RPTR(FRAME)TEMP,BROTHER;
$LAST←MRG; ! used by kill instruction;
TEMP←FRAME:SON[STARTFR];
DO BEGIN
BROTHER←FRAME:EBRO[TEMP];
PCOPY(TEMP,FINALFR,PREFIX); ! copies one subtree;
TEMP←BROTHER;
END
UNTIL TEMP=NULL_RECORD;
END;
! executes copy or merge operation on frame1 and frame2. Name indicates
the required operation(copy/merge);
PROCEDURE COPYCODE(STRING NAME,FRAME1,FRAME2);
BEGIN
RPTR(FRAME) FR1,FR2;STRING PREFIX,ANSWER;
$ALLOW←$ALLOW+1;
FR1←BELONGS (FRAME1,#FR); ! frame1 must be a frame;
FR2←BELONGS (FRAME2,#FR); ! frame2 must be a frame;
! chooses the prefix for the new names: if the name of frame2 contains an
underscore takes the part before it, otherwise takes the first three
characters (long names) or all the name and asks for a confirmation;
ANSWER←FRAME:PNAME[FR2];
PREFIX←SCAN(ANSWER,$DSHTAB,$BRCHR);
IF $BRCHR=0 AND
LENGTH(PREFIX)>5 THEN
PREFIX←FRAME:PNAME[FR2] [1 FOR 3];
PRINT("it's OK to prefix to the new names ");
PREFIX←RECOVER(PREFIX)&"_";
$LAST←CPY; ! changed after if merge;
IF NAME="COPY"
THEN PCOPY(FR1,FR2,PREFIX)
ELSE PMERGE(FR1,FR2,PREFIX);
$ALLOW←$ALLOW-1;
$FRLST←NULL; ! to update the display;
UPDATE;
END;
! arm interactions: read_pos,readarm,asgloc,frasg,inputcode;
REQUIRE "ARMINT.SAI[PNT,HE]" SOURCE_FILE;
! assigns the value of pos(pointer or arm) to the frame fra. If direct
is indicated uses it to set the rotation part;
PROCEDURE ASGLOC(RPTR(FRAME) POS,FRA;INTEGER DIRECT(#INDEF));
BEGIN
REAL ARRAY FXF[1:5,1:4];
ABSXF(POS,FXF); ! absolute value of pos;
IF DIRECT="↑"
THEN SET_ROTATION(FXF,0.,0.,0.)
ELSE IF DIRECT="↓" OR DIRECT="∧"
THEN SET_ROTATION(FXF,0.,180.,0.)
ELSE IF DIRECT="α" OR DIRECT="∨"
THEN SET_ROTATION(FXF,-180,180,0)
else if direct="<" then set_rotation(fxf,-90,180,0)
else if direct=">" then set_rotation(fxf,90,180,0);
SETABSXF(FRA,FXF); ! sets value of fra;
END;
! reads the position of yellow arm (TEMPORARY);
PROCEDURE READ_YELLOW(REAL ARRAY AXF);
BEGIN
INTEGER I;STRING AA; REAL ARRAY COMP[1:6];
PRINT(" Assign 6 values (angles and positions)",CRLF);
FOR I← 1 STEP 1 UNTIL 6 DO
BEGIN
AA←INCHWL;
IF $OUT THEN CPRINT($TTYCH,AA,CRLF);
COMP[I]←REALSCAN(AA,$BRCHR);
END;
SET_ROTATION(AXF,COMP[1],COMP[2],COMP[3]);
AXF[1,4]←COMP[4];
AXF[2,4]←COMP[5];
AXF[3,4]←COMP[6];
END;
! This procedure finds out where the arm actually is and then
stores this frame as the absolute frame of the arm in the
subpart hierarchy.;
PROCEDURE READARM(RPTR(FRAME) POS);
BEGIN
OWN REAL ARRAY AXF[1:5,1:4];
$FRLST←NULL; ! frame tree modification;
IF POS=F_YARM
THEN BEGIN
PRINT ("simulation of reading on ",frame:pname[pos]);
READ_YELLOW(AXF);
SETABSXF(POS,AXF);
END
ELSE IF POS = F_BARM
THEN BEGIN
READ_BLUE(AXF);
SCALAR:VALUE[S_BHAND]←BHAND;
SETABSXF(POS,AXF);
END
ELSE PRINT("No such arm.");
END;
! returns the pointer to the input device pos (arm or pointer);
RPTR (FRAME) PROCEDURE INPT_DEV(REFERENCE STRING POS);
BEGIN
RPTR(FRAME) FROM;
IF EQU(POS,"BARM")
THEN RETURN(F_BARM)
ELSE IF EQU(POS,"YARM")
THEN RETURN(F_YARM)
ELSE BEGIN
FROM←BELONGS(POS,#FR);
WHILE FROM≠F_BARM AND FROM≠F_YARM AND FROM≠F_POINTER
DO BEGIN
PRINT ($SEMSG[12]);
POS←RECOVER(POS);
FROM←BELONGS (POS,#FR);
END;
RETURN(FROM);
END;
END;
! reads the position of the arm from, or of the arm with pointer;
PROCEDURE READ_DEV(RPTR(FRAME) FROM);
BEGIN
IF FROM=F_POINTER THEN READARM(ARM) ELSE READARM(FROM);
END;
! reads the position of the device pos (arm or pointer);
PROCEDURE INPT(REFERENCE STRING POS);
BEGIN
RPTR(FRAME)FROM;
FROM←INPT_DEV(POS);
READ_DEV(FROM);
END;
! assigns to fst the values read on pos. Direct predefines the orientation;
PROCEDURE INPUTCODE(STRING FST;INTEGER DIRECT;STRING POS);
BEGIN "A"
RPTR(FRAME) FROM,FRDEF;
! asserts that the fiducial is currently at the ARM frame;
PROCEDURE FIDDEF(RPTR(FRAME)FROM);
BEGIN "FIDUCIAL"
F_FID←FR_INSERT(FST); ! inserts the new frame;
! f_fid=pointer to FIDUCIAL;
IF DIRECT≠#INDEF THEN PRINT("orientation assigned not used",CRLF);
AFX_NODE(F_FID,F_WORLD,#NRGLK); ! affixes fiducial to world;
ASGLOC(FROM,F_FID); ! assigns values read to fid;
END "FIDUCIAL";
! sets the absolute frame of the pointer equal to that of the fiducial;
PROCEDURE PNTASG(RPTR(FRAME) FROM);
BEGIN "POINTER"
IF NOT F_FID THEN ABORT1("FIDUCIAL",$SEMSG[3]);
F_POINTER←FR_INSERT(FST); ! inserts the new frame;
! f_pointer=pointer to POINTER;
ARM←FROM; ! remembers which arm holds pointer;
IF DIRECT≠#INDEF THEN PRINT("orientation assigned not used",CRLF);
ASGLOC(F_FID,F_POINTER); ! assigns fiducial pos. to pointer;
AFX_NODE(F_POINTER,ARM,#RGDLK); ! affixes pointer to the arm;
END "POINTER";
$LAST←ASG; ! for kill instruction;
$ALLOW←$ALLOW+1;
FROM←INPT_DEV(POS); ! pos must be a input device;
READ_DEV(FROM); ! reads the arm position;
IF EQU(FST,"FIDUCIAL")
THEN FIDDEF(FROM)
ELSE IF EQU(FST,"POINTER")
THEN PNTASG(FROM)
ELSE BEGIN
FRDEF←FR_INSERT(FST); ! inserts the new frame;
ASGLOC(FROM,FRDEF,DIRECT); ! assigns value to frdef;
END;
$ALLOW←$ALLOW-1;
UPDATE;
END "A";
! arm interactions: arm_check,goarm,movefrfr;
! returns the pointer to the arm affixed to obj;
RPTR(FRAME) PROCEDURE ARM_CHECK(RPTR(FRAME) OBJ);
BEGIN
RPTR(FRAME) TEMP;
IF OBJ=F_BARM OR OBJ=F_YARM
THEN RETURN(OBJ);
IF OBJ=F_POINTER
THEN RETURN(ARM);
IF OBJ=F_WORLD
THEN ABORT1("STATION ",$SEMSG[8]); ! impossible move the world;
TEMP←FRAME:DAD[OBJ];
WHILE TEMP≠F_WORLD
DO BEGIN
IF TEMP=F_YARM OR TEMP=F_BARM
THEN RETURN(TEMP);
TEMP←FRAME:DAD[TEMP];
END;
ABORT1(FRAME:PNAME[OBJ],$SEMSG[8]);
END;
! This procedure moves the arm MVARM to BXF;
! PARKING=1 for arm parking;
FORWARD PROCEDURE ARRPRINT(REAL ARRAY XF);
PROCEDURE GOARM(RPTR(FRAME)MVARM;REAL ARRAY BXF;INTEGER PARKING(0));
BEGIN
integer i,j;real array bbb[1:5,1:4];
! this part has been introduced to transpose the rotation part of
the matrix for movements. It would be better to insert it in the
interface part;
ARRTRAN(BBB,BXF);
FOR I←1 STEP 1 UNTIL 3 DO
FOR J←1 STEP 1 UNTIL 3 DO
BBB[I,J]←BXF[J,I];
IF MVARM=F_BARM
THEN MOVE_B(BBB,PARKING)
ELSE PRINT("simulation of yarm movement ",CRLF);
SETABSXF(MVARM,BXF); ! sets value of arm;
END;
! Suppose the absolute frame of the arm is AXF
the absolute frame of "motion" is MXF
and we want the new motion frame to be TRANS:xf[DEST].
We therefore have to compute the new arm frame TRANS:xf[BXF].
This means MXF = AXF * X where X is the displacement trans between the
arm and the motion frames. So X = inverse(AXF) * MXF. Then DEST = BXF * X
So, BXF = DEST * inverse(X) = DEST * inverse(MXF) * AXF.;
RPTR(TRANS)PROCEDURE MOVEFRFR(RPTR(FRAME) MVARM,OBJ;RPTR(TRANS)DEST);
BEGIN
OWN REAL ARRAY MXF[1:5,1:4],
AXF[1:5,1:4],
TMP[1:5,1:4];
RPTR(TRANS) BXF;
BXF←NEW_XFELT;
if mvarm=obj
then arrtran(TRANS:xf[bxf],TRANS:xf[dest])
else begin
ABSXF(MVARM,AXF); ! AXF is arm frame;
ABSXF(OBJ,MXF); ! MXF is motion frame;
INVXFXF(MXF,AXF,TMP); ! TMP = inv(MXF) * AXF;
XFXFMUL(TRANS:XF[DEST],TMP,TRANS:XF[BXF]); ! BXF = DEST*inv(MXF)*AXF;
end;
RETURN(BXF);
END;
! returns the destination part: fra + absvt;
RPTR(TRANS) PROCEDURE DESTVT(RPTR(FRAME) FRA;REAL ARRAY ABSVT);
BEGIN
RPTR(TRANS) TEMP;
TEMP←ABSLOC(FRA); ! absolute value of fra;
TRANS:XF[TEMP][1,4]←TRANS:XF[TEMP][1,4] + ABSVT[1];
TRANS:XF[TEMP][2,4]←TRANS:XF[TEMP][2,4] + ABSVT[2];
TRANS:XF[TEMP][3,4]←TRANS:XF[TEMP][3,4] + ABSVT[3];
RETURN(TEMP);
END;
! arm interactions: mvfrcode,mvfrexp;
! moves fr1 to fr2 + expl.vect WRT rel (fr2 can be ⊗);
PROCEDURE MVFREXP (STRING FRAME1,FRAME2;RPTR(VECTOR) VET;STRING RELFR);
BEGIN
REAL ARRAY ABSVT,RELVT[1:3];RPTR(TRANS)TEMP;RPTR(FRAME)FR1,FR2,REL,MVARM;
$LAST←KIL; ! unkillable instruction;
$ALLOW←$ALLOW+1;
IF EQU(FRAME1,"BARM") AND EQU(FRAME2,"BPARK") AND VET=V_NILVECT
THEN GOARM(F_BARM,FRAME:XF[F_BPARK],1)
ELSE BEGIN "MOVE"
! finds rptr to frame1 and frame2;
FR1←BELONGS (FRAME1,#FR);
IF FRAME2≠"⊗"
THEN FR2←BELONGS (FRAME2,#FR)
ELSE FR2←FR1; ! FR2←FR1;
! checks frame1 is movable and finds the arm which is affixed to;
MVARM←ARM_CHECK(FR1);
IF MVARM=F_BARM THEN READARM(MVARM); ! reads exact postion of arm;
! computes the absolute values of the vector (in absvt);
IF VET≠V_NILVECT
THEN BEGIN
GETVTVAL(VET,ABSVT);
IF NOT EQU(RELFR,"STATION") AND RELFR
THEN BEGIN
REL←BELONGS (RELFR,#FR); ! relfr must be a frame;
WRTVTC(ABSVT,RELVT,REL);
ARRTRAN(ABSVT,RELVT);
END;
END;
! computes the final position for the arm mvarm;
IF FR1=FR2
THEN TEMP←DESTVT(MVARM,ABSVT)
ELSE BEGIN
IF VET≠V_NILVECT
THEN TEMP←DESTVT(FR2,ABSVT)
ELSE TEMP←ABSLOC(FR2);
TEMP←MOVEFRFR(MVARM,FR1,TEMP); ! computes final pos.of arm;
END;
! moves the arm ;
GOARM(MVARM,TRANS:XF[TEMP]);
END "MOVE";
$ALLOW←$ALLOW-1;
$FRLST←NULL;
UPDATE;
END ;
! arm interactions: freecode,centercode,closecode,opencode,implconstr;
! executes center instruction;
PROCEDURE CENTERCODE(STRING POS);
BEGIN
$LAST←KIL; ! unkillable instruction;
IF POS="BARM"
THEN BEGIN
CENT_B ;
READARM(F_BARM);
$FRLST←NULL;
$SCLST←NULL;
UPDATE;
END
ELSE PRINT(#NOTYET);
END;
! executes close or open instruction. How determines if the movement is
absolute (to) or differential (by), op indicates the operation(open/close);
PROCEDURE OPCLCODE(STRING OP,HAND,HOW;REAL SCAL);
BEGIN
$LAST←KIL; ! unkillable instruction;
IF HAND="BHAND"
THEN BEGIN
IF HOW="TO"
THEN OPEN_B_ABS(SCAL)
ELSE IF OP="CLOSE"
THEN OPEN_B_DEL(-SCAL)
ELSE OPEN_B_DEL(SCAL);
READARM(F_BARM);
$SCLST←NULL;
UPDATE;
END
ELSE PRINT(#NOTYET);
END;
! drives the indicated joint of the arm (what): movement is absolute
if how=to, differential if how=by;
PROCEDURE DRIVECODE(STRING WHAT,HOW;INTEGER JOINT;REAL SCAL);
BEGIN
$LAST←KIL;
IF EQU(WHAT,"BJT")
THEN BEGIN
IF EQU(HOW,"BY")
THEN DRIVE_B_DEL(JOINT,SCAL)
ELSE DRIVE_B_ABS(JOINT,SCAL);
READARM(F_BARM);
$FRLST←NULL;
UPDATE;
END
ELSE IF EQU(WHAT,"YJT")
THEN PRINT(#NOTYET);
END;
! reads an axis name and returns its number:
xhat=0,yhat=1,zhat=2;
INTEGER PROCEDURE INPT_AXIS(REFERENCE STRING AXIS);
BEGIN
LABEL LL;
LL: AXIS←RECOVER(AXIS);
IF EQU(AXIS,"XHAT") THEN RETURN(0)
ELSE IF EQU(AXIS,"YHAT") THEN RETURN(1)
ELSE IF EQU(AXIS,"ZHAT") THEN RETURN(2)
ELSE BEGIN
PRINT($SYNMSG[17],$SYNMSG[25],CRLF,"Try again ");
GOTO LL;
END;
END;
! performs a construct instruction, without arguments;
PROCEDURE IMPLCONSTR(STRING FIRST);
BEGIN
RPTR(FRAME) ELF;RPTR(TRANS)XFE;INTEGER I;
RPTR(FRAME) FROM;STRING POS,ANSWER;
PRELOAD_WITH
"move arm to the origin of the frame"&CRLF,
"move arm to the axis ",
"move arm to the plane ";
OWN STRING ARRAY INFORM[1:3];
REAL ARRAY COMPA,COMPB,COMPC[1:3];
STRING AXIS;INTEGER F_AXIS,S_AXIS;
$LAST←ASG; ! for kill instruction;
$ALLOW←$ALLOW+1;
AXIS←NULL;
IF F_POINTER=NULL_RECORD
THEN PRINT("pointer not defined cannot be used",CRLF)
ELSE POS←"POINTER";
PRINT("three positions are required",CRLF);
FOR I←1 STEP 1 UNTIL 3 DO
BEGIN
! determination of the input device required;
PRINT("position ",I," read on ");
POS←RECOVER(POS);
FROM←INPT_DEV(POS); ! checks the input device;
! determination of the positions for reading;
PRINT(INFORM[I]);
IF I=2
THEN F_AXIS←INPT_AXIS(AXIS)
ELSE IF I=3
THEN BEGIN
PRINT(AXIS," - ");
AXIS←NULL;
S_AXIS←INPT_AXIS(AXIS);
IF S_AXIS=F_AXIS THEN ABORT1(" ",$SEMSG[15]);
END;
! reading of the arm position;
PRINT("type <cr> when the arm is at the desired position");
ANSWER←INCHRW;
IF ANSWER=CR
THEN ANSWER←INCHRW
ELSE ABORT1(" ",$SEMSG[15]);
READ_DEV(FROM); ! raads the appropriate arm pos.;
IMPLF[I]←ABSLOC(FROM);
END;
! extraction of translation part;
GETVTTR(IMPLF[1],COMPA);
GETVTTR(IMPLF[2],COMPB);
GETVTTR(IMPLF[3],COMPC);
XFE←VVVTRANS(COMPA,COMPB,COMPC,F_AXIS,S_AXIS);
ELF←FR_INSERT(FIRST); ! inserts the new frame;
ABSSET(ELF,XFE); ! sets the new value;
$ALLOW←$ALLOW-1;
UPDATE;
END;
! input/output: altf,altrans,alframe,aldec,al_subtree,alid, (unique_id);
! types on the file (open on $ALCH) the frame declaration and assignment
of affixment for the frame pointed by nd. If the frame is affixed
independently an assignment instruction is generated, otherwhise an
affix instruction, with the correct type of affixment is produced;
PROCEDURE ALDEC(RPTR(FRAME) ND);
BEGIN
STRING NAME,DS,FS;
NAME←FRAME:PNAME[ND]; ! frame pname;
DS←"FRAME "&NAME&";"&CRLF; ! declaration;
IF FRAME:HOWLINKED[ND]=#INDLK
THEN FS←NAME&" ← FRAME"&STR_TR(FRAME:XF[ND])&";"&DLF
ELSE BEGIN
FS←"AFFIX "&NAME&" TO "&FRAME:PNAME[FRAME:DAD[ND]]&" AT"
&CRLF&BLANKS[1 TO 6]&"TRANS"&STR_TR(FRAME:XF[ND]);
IF FRAME:HOWLINKED[ND]=#NRGLK
THEN FS←FS&" NONRIGIDLY;"&DLF
ELSE FS←FS&" RIGIDLY;"&DLF;
END;
CPRINT($ALCH,DS,FS);
END;
! finds the different frames looking at the frame tree;
RECURSIVE PROCEDURE AL_SUBTREE(RPTR(FRAME) ND);
BEGIN
RPTR(FRAME) SN;
IF ND≠F_WORLD AND ND≠F_YARM AND ND≠F_BARM AND ND≠F_POINTER
AND ND≠F_BPARK AND ND≠F_YPARK AND ND≠F_FID AND ND≠F_BGRASP AND ND≠F_BGRASP
THEN ALDEC(ND);
SN←FRAME:SON[ND];
WHILE SN≠NULL_RECORD
DO BEGIN
AL_SUBTREE(SN);
SN←FRAME:EBRO[SN];
END;
END;
! types on the file (open on $ALCH) the scalar declarations and
assignments;
PROCEDURE AL_SCALAR;
BEGIN
INTEGER ADDRIN,ADDRFN,I;STRING DS,SS;RPTR(SYMBOL)ADDR;
! first two scalars in $YMTAB are bhand and yhand: so addrin is
the initial address of scalars defined by the user;
ADDRIN←#LTYPE*#SC+2;
ADDRFN←$ENTRY[#SC]-1; ! final address of scalars;
FOR I←ADDRIN STEP 1 UNTIL ADDRFN DO
BEGIN
ADDR←$YMTAB[I];
IF ADDR≠NULL_RECORD
THEN BEGIN ! skips deleted variables;
DS←"SCALAR "&SYMBOL:PNAME[ADDR]&";"&CRLF;
SS←SYMBOL:PNAME[ADDR]&" ← "
&CVGX(SCALAR:VALUE[SYMBOL:OBJECT[ADDR]])&";"&DLF;
CPRINT($ALCH,DS,SS);
END;
END;
END;
! types on the file (open on $ALCH) the vector declarations and
assignments;
PROCEDURE AL_VECTOR;
BEGIN
INTEGER ADDRIN,ADDRFN,I;RPTR(VECTOR)IND;STRING DS,VS;RPTR(SYMBOL)ADDR;
! first four vectors in $YMTAB are nilvect and the axis: so addrin is
the initial address of vectors defined by the user;
ADDRIN←#LTYPE*#VT+4;
ADDRFN←$ENTRY[#VT]-1; ! final address of vectors;
FOR I←ADDRIN STEP 1 UNTIL ADDRFN DO
BEGIN
ADDR←$YMTAB[I];
IF ADDR≠NULL_RECORD
THEN BEGIN ! skips deleted variables;
IND←SYMBOL:OBJECT[ADDR];
DS←"DISTANCE VECTOR "&SYMBOL:PNAME[ADDR]&";"&CRLF;
VS←SYMBOL:PNAME[ADDR]&" ← "
&STR_VT(VECTOR:XC[IND],VECTOR:YC[IND],VECTOR:ZC[IND])
&";"&DLF;
CPRINT($ALCH,DS,VS);
END;
END;
END;
! types on the file (open on $ALCH) the rotation declarations and
assignments. The rotation are expressed by a product of rotations
about zhat,yhat and zhat;
PROCEDURE AL_ROT;
BEGIN
INTEGER ADDRIN,ADDRFN,I;STRING DS,RS;RPTR(SYMBOL)ADDR;
! first rot in $YMTAB is nilrotn: so addrin is
the initial address of rotations defined by the user;
ADDRIN←#LTYPE*#RT+1;
ADDRFN←$ENTRY[#RT]-1; ! final address of rot;
FOR I←ADDRIN STEP 1 UNTIL ADDRFN DO
BEGIN
ADDR←$YMTAB[I];
IF ADDR≠NULL_RECORD
THEN BEGIN ! skips deleted variables;
DS←"ROT "&SYMBOL:PNAME[ADDR]&";"&CRLF;
RS←SYMBOL:PNAME[ADDR]&" ← "
&STR_RT(ROT:XF[SYMBOL:OBJECT[ADDR]])&";"&DLF;
CPRINT($ALCH,DS,RS);
END;
END;
END;
PROCEDURE AL_TRANS;
BEGIN
INTEGER ADDRIN,ADDRFN,I;STRING DS,TR;RPTR(SYMBOL)ADDR;
! first trans in $YMTAB is niltrans: so addrin is
the initial address of transes defined by the user;
ADDRIN←#LTYPE*#TR+1;
ADDRFN←$ENTRY[#TR]-1; ! final address of transes;
FOR I←ADDRIN STEP 1 UNTIL ADDRFN DO
BEGIN
ADDR←$YMTAB[I];
IF ADDR≠NULL_RECORD
THEN BEGIN ! skips deleted variables;
DS←"TRANS "&SYMBOL:PNAME[ADDR]&";"&CRLF;
TR←SYMBOL:PNAME[ADDR]&" ← TRANS"
&STR_TR(TRANS:XF[SYMBOL:OBJECT[ADDR]])&";"&DLF;
CPRINT($ALCH,DS,TR);
END;
END;
END;
! input/output: readexec,readcode,writecode,alfile,close,al_close;
FORWARD RECURSIVE PROCEDURE PARSE;
PROCEDURE READEXEC;
BEGIN "A"
INTEGER CHAR;
DPYCLR;DPYSET(∂BUF);
TYPLOC($DTMAR-CHRSIZE,$PTMAR);DPYOUT(1);
$TAIL←INPUT($INPCH,$SCNTAB);
WHILE NOT $EOF DO
BEGIN
IF NOT EQU($TAIL[1 TO 7],"COMMENT")
THEN BEGIN
PRINT($TAIL,CRLF);
PARSE;
END;
CHAR←INCHRS;
IF CHAR≥0 THEN DONE;
$TAIL←INPUT($INPCH,$SCNTAB);
END;
RELEASE($INPCH);
$READ←FALSE;
$ALLOW←0;
PRINT(CRLF,"type <CR> to come back to the display");
CHAR←INCHRW;CLRBUF;
UPDATE;
$LAST←KIL;
END "A";
PROCEDURE READCODE(STRING FID);
BEGIN
OPEN($INPCH←GETCHAN,"DSK",0,3,0,1000,$BRCHR,$EOF);
LOOKUP($INPCH,FID,$EOF);
WHILE $EOF
DO BEGIN
PRINT($SEMSG[16]);
FID←FLRECOVER(FID);
LOOKUP($INPCH,FID,$EOF);
END;
$READ←TRUE;
$ALLOW←$ALLOW+1;
READEXEC;
END;
! if the file has been previously used returns its number in table,
otherwise returns 0;
INTEGER PROCEDURE ALFILE(STRING FILE);
BEGIN
INTEGER I;
FOR I←1 STEP 1 UNTIL $TOTFL DO
IF EQU($NAMEFL[I],FILE) THEN RETURN (I);
RETURN(0);
END;
PROCEDURE FCLOSE;
BEGIN
INTEGER IND;
$LAST←KIL;
FOR IND←1 STEP 1 UNTIL $TOTFL DO
BEGIN
$CHNFL[IND,0]←1; ! sets the file closed in table;
PRINT("CLOSING ",$NAMEFL[IND],CRLF);
ESC_P;
RELEASE($CHNFL[IND,1]); ! releases channels;
$ALFL←"DECLAR.AL"; ! new default file;
END;
IF $OUT
THEN BEGIN
PRINT("CLOSING ",$TTYFL,CRLF);ESC_P;
RELEASE($TTYCH,0); ! closes the tty save file;
$OUT←FALSE; ! sets the flag;
END;
$OULST←NULL;$TTYFL←NULL; ! file status modified;
UPDATE;
END;
CLEANUP FCLOSE;
! close the file open;
PROCEDURE AL_CLOSE(STRING FILE );
BEGIN
INTEGER IND;
$LAST←KIL;
IND←ALFILE(FILE); ! address of file in table;
WHILE IND=0
DO BEGIN
PRINT($SEMSG[14]);
FILE←FLRECOVER(FILE); ! recovers not existent file;
IND←ALFILE(FILE);
END;
$CHNFL[IND,0]←1; ! closes the file;
RELEASE($CHNFL[IND,1]);
! looks for an open file: if no file is open DECLAR.AL is proposed;
$ALFL←"DECLAR.AL";
IND←$TOTFL;
WHILE IND DO
IF $CHNFL[IND,0]
THEN IND←IND-1
ELSE BEGIN
$ALFL←$NAMEFL[IND]; ! name of open file;
DONE;
END;
$OULST←NULL; ! file status modified;
UPDATE;
END;
PROCEDURE SAVE1(STRING FILE);
BEGIN
STRING OLDCNT;
CLOSO($ALCH); ! closes the file;
ENTER($ALCH,FILE,$EOF); ! enters the new file;
WHILE $EOF
DO BEGIN
PRINT($SEMSG[13]);
FILE←FLRECOVER(FILE);
ENTER($ALCH,FILE,$EOF);
END;
OPEN($INPCH←GETCHAN,"DSK",0,3,0,1000,$BRCHR,$EOF); ! open again the previous file;
LOOKUP($INPCH,FILE,$EOF);
WHILE $EOF
DO BEGIN
PRINT($SEMSG[16]);
FILE←FLRECOVER(FILE);
LOOKUP($INPCH,FILE,$EOF);
END;
! the file is copied into the new file;
WHILE $EOF=0 DO
BEGIN
OLDCNT←INPUT($INPCH,0);
CPRINT($ALCH,OLDCNT);
END;
END;
PROCEDURE SAVECODE(STRING FILE);
BEGIN
INTEGER IND,ALEOF;
$LAST←KIL;
IND←ALFILE(FILE); ! address of file in table;
WHILE IND=0
DO BEGIN
PRINT($SEMSG[14]);
FILE←FLRECOVER(FILE); ! recovers not existent file;
IND←ALFILE(FILE);
END;
IF $CHNFL[IND,0]=0
THEN BEGIN
$ALCH←$CHNFL[IND,1];
SAVE1(FILE);
END;
END;
PROCEDURE FSAVE; ! saves all open files;
BEGIN
INTEGER I;
FOR I←1 STEP 1 UNTIL $TOTFL DO
IF $CHNFL[I,0]=0
THEN BEGIN
$ALCH←$CHNFL[I,1];
SAVE1($NAMEFL[I]);
END;
IF $OUT
THEN BEGIN
$ALCH←$TTYCH;
SAVE1($TTYFL);
END;
END;
PROCEDURE WRITECODE(STRING FILE,ROOT);
BEGIN
RPTR(FRAME) EL;INTEGER IND;
PROCEDURE OPENFILE(INTEGER IND(0));
BEGIN
INTEGER ALEOF;
OPEN($ALCH←GETCHAN,"DSK",0,1,3,0,0,ALEOF);
ALEOF←-1;
ENTER($ALCH,FILE,ALEOF);
WHILE ALEOF
DO BEGIN
PRINT($SEMSG[13]);
FILE←FLRECOVER(FILE);
ENTER($ALCH,FILE,ALEOF);
END;
IF IND>0 AND EQU($NAMEFL[IND],FILE)
THEN BEGIN
$CHNFL[IND,0]←0;
$CHNFL[IND,1]←$ALCH;
END
ELSE BEGIN
$TOTFL←$TOTFL+1; ! enters the new file;
$NAMEFL[$TOTFL]←FILE;
$CHNFL[$TOTFL,1]←$ALCH; ! channel number;
$CHNFL[$TOTFL,0]←0; ! the file is open;
END;
$OULST←NULL; ! file status modified;
END;
$LAST←KIL;
EL←BELONGS (ROOT,#FR); ! checks if root is a frame;
IND←ALFILE(FILE);
IF IND = 0
THEN OPENFILE
ELSE IF $CHNFL[IND,0]
THEN BEGIN
STRING STR;
PRINT("file existent, but closed (type Y to overwrite)");
STR←INCHRW;IF STR=CR THEN STR←INCHRW;
PRINT(CRLF);
IF STR="Y" OR str="y"
THEN OPENFILE(IND)
ELSE ABORT1(" ",$SEMSG[15]);
END
ELSE $ALCH←$CHNFL[IND,1]; ! channel number;
IF NOT EQU(FILE,$ALFL)
THEN BEGIN
$ALFL←FILE; ! last file used for output;
$OULST←NULL;
END;
UPDATE;
IF EL=F_WORLD
THEN BEGIN ! complete output;
AL_SCALAR; ! outputs the scalars;
AL_VECTOR; ! outputs th vectors;
AL_ROT; ! outputs the rotations;
AL_TRANS;
END;
AL_SUBTREE(EL); ! outputs the frame tree;
END;
! system facilities: editcode,killcode,killtree,killvar;
FORWARD RPTR(ROT)PROCEDURE ROT_PART;
FORWARD RPTR(TRANS)PROCEDURE TRANS_PART;
FORWARD SIMPLE PROCEDURE LPAR_READ;
! edits values of the variable var;
PROCEDURE EDITCODE (STRING VAR);
BEGIN
RPTR(SYMBOL)EL;INTEGER OBTYPE;STRING ANSWER,COMMA;
BOOLEAN PROCEDURE NOT_COMMA;
BEGIN
COMMA←LOP(ANSWER);
IF COMMA≠"," THEN BEGIN
PRINT("error in editing. Try again",CRLF);
RETURN(TRUE);
END
ELSE RETURN(FALSE);
END;
PROCEDURE SC_EDIT;
BEGIN
RPTR(SCALAR) TEMP;
TEMP←SYMBOL:OBJECT[EL];
PRINT("value of ",VAR," = ");
LODED( CVGX(SCALAR:VALUE[TEMP])&CR);
ANSWER←INCHWL;
IF $OUT THEN CPRINT($TTYCH,ANSWER,CRLF);
SCALAR:VALUE[TEMP]←REALSCAN(ANSWER,$BRCHR);
$SCLST←NULL; ! scalar modification;
END;
PROCEDURE VT_EDIT;
BEGIN
RPTR(VECTOR) TEMP; LABEL LV;
TEMP←SYMBOL:OBJECT[EL];
LV:PRINT("values of ",VAR," = ");
LODED(STR_VT(VECTOR:XC[TEMP],
VECTOR:YC[TEMP],(VECTOR:ZC[TEMP]),8)&CR);
ANSWER←INCHWL;
IF $OUT THEN CPRINT($TTYCH,ANSWER,CRLF);
VECTOR:XC[TEMP]←REALSCAN(ANSWER,$BRCHR);
IF NOT_COMMA THEN GO TO LV; ! recovers error;
VECTOR:YC[TEMP]←REALSCAN(ANSWER,$BRCHR);
IF NOT_COMMA THEN GO TO LV;
VECTOR:ZC[TEMP]←REALSCAN(ANSWER,$BRCHR);
$VTLST←NULL; ! vector modification;
END;
PROCEDURE RT_EDIT;
BEGIN
RPTR(ROT)TEMP,TEMP1;
TEMP←SYMBOL:OBJECT[EL];
PRINT("values of ",VAR," = ");
LODED(STR_RT(ROT:XF[TEMP],4)&CR);
$TAIL←INCHWL;
IF $OUT THEN CPRINT($TTYCH,$TAIL,CRLF);
TEMP1←ROT_PART;
ARRTRAN(ROT:XF[TEMP],ROT:XF[TEMP1]);
$RTLST←NULL; ! rotation modification;
END;
PROCEDURE FR_EDIT;
BEGIN "ED"
RPTR(FRAME)TEMP;
RPTR(TRANS) TEMP1;
TEMP←SYMBOL:OBJECT[EL];
IF FRAME:HOWLINKED[TEMP]≠#INDLK
THEN PRINT("values of ",VAR," are relative to ",
FRAME:PNAME[FRAME:DAD[TEMP]],CRLF);
PRINT("values of ",VAR," = ");
LODED(STR_TR(FRAME:XF[TEMP],4,8)&CR);
$TAIL←INCHWL;
IF $OUT THEN CPRINT($TTYCH,$TAIL,CRLF);
LPAR_READ;
TEMP1←TRANS_PART;
ARRTRAN(FRAME:XF[TEMP],TRANS:XF[TEMP1]);
$FRLST←NULL; ! frame tree modification;
END;
PROCEDURE TR_EDIT;
BEGIN
RPTR(TRANS)TEMP,TEMP1;
TEMP←SYMBOL:OBJECT[EL];
PRINT("values of ",VAR," = ");
LODED(STR_TR(TRANS:XF[TEMP],4,8)&CR);
$TAIL←INCHWL;
IF $OUT THEN CPRINT($TTYCH,$TAIL,CRLF);
LPAR_READ;
TEMP1←TRANS_PART;
ARRTRAN(TRANS:XF[TEMP],TRANS:XF[TEMP1]);
$TRLST←NULL; ! frame tree modification;
END;
$LAST←KIL; ! unkillable instruction;
EL←OLDSYM(VAR,OBTYPE); ! var must exist in $YMTAB;
SETFORMAT(0,7);
CASE OBTYPE OF
BEGIN "CASE"
[#SC] SC_EDIT;
[#VT] VT_EDIT;
[#RT] RT_EDIT;
[#FR] FR_EDIT;
[#TR] TR_EDIT
END "CASE";
SETFORMAT(0,3);
UPDATE;
END;
! allows renaming a variable;
PROCEDURE RENMCODE(STRING VAR);
BEGIN
RPTR(SYMBOL)OLDEL;INTEGER OBTYPE;STRING NEW;
$LAST←KIL; ! unkillable instruction;
OLDEL←OLDSYM(VAR,OBTYPE); ! var must exist in $YMTAB;
PRINT("new name = ");
NEW←RECOVER(VAR); ! reads the new name;
NEW←NEWSYM(NEW); ! checks new doesn't exist;
IF $OUT THEN CPRINT($TTYCH,NEW,CRLF);
SYMBOL:PNAME[OLDEL]←NEW; ! changes the name in record symbol;
IF OBTYPE=#FR
THEN FRAME:PNAME[SYMBOL:OBJECT[OLDEL]]←NEW;
CASE OBTYPE OF
BEGIN
[#SC] $SCLST←NULL;
[#VT] $VTLST←NULL;
[#RT] $RTLST←NULL;
[#FR] $FRLST←NULL;
[#TR] $TRLST←NULL
END;
UPDATE;
END;
! restores previous value of a scalar (used by kill instruction);
PROCEDURE SC_RECOVER;
BEGIN
RPTR(SCALAR) EL;
EL←SYMBOL:OBJECT[ADDRPTR[INDADDR]]; ! pointer to the variable;
INDSCVT←INDSCVT-1;
SCALAR:VALUE[EL]←SCVTSAVED[INDSCVT]; ! value;
$SCLST←NULL;
END;
! restores previous value of a vector (used by kill instruction);
PROCEDURE VT_RECOVER;
BEGIN
RPTR(VECTOR)EL;
EL←SYMBOL:OBJECT[ADDRPTR[INDADDR]]; ! pointer to the vector;
INDSCVT←INDSCVT-3;
VECTOR:ZC[EL]←SCVTSAVED[INDSCVT+2]; ! values of three components;
VECTOR:YC[EL]←SCVTSAVED[INDSCVT+1];
VECTOR:XC[EL]←SCVTSAVED[INDSCVT];
$VTLST←NULL;
END;
! restores previous value of a frame (used by kill instruction);
PROCEDURE FR_RECOVER;
BEGIN
RPTR(FRAME) EL;
EL←SYMBOL:OBJECT[ADDRPTR[INDADDR]]; ! pointer to the frame;
INDRTFR←INDRTFR-1;
ARRTRAN(FRAME:XF[EL],TRANS:XF[RTFRSAVED[INDRTFR]]);
$FRLST←NULL;
END;
! restores previous value of a rotation (used by kill instruction);
PROCEDURE RT_RECOVER;
BEGIN
RPTR(ROT)EL;
EL←SYMBOL:OBJECT[ADDRPTR[INDADDR]]; ! pointer to the rot;
INDRTFR←INDRTFR-1;
ARRTRAN(ROT:XF[EL],TRANS:XF[RTFRSAVED[INDRTFR]]);
$RTLST←NULL;
END;
! restores previous value of a transformation (used by kill instruction);
PROCEDURE TR_RECOVER;
BEGIN
RPTR(TRANS)EL;
EL←SYMBOL:OBJECT[ADDRPTR[INDADDR]]; ! pointer to the trans;
INDRTFR←INDRTFR-1;
ARRTRAN(TRANS:XF[EL],TRANS:XF[RTFRSAVED[INDRTFR]]);
$TRLST←NULL;
END;
! restores previous structure of the tree (used by kill instruction);
PROCEDURE TREE_RECOVER;
BEGIN
INDTREE←INDTREE-1;
LNK_NODE(TREESAVED[INDTREE,0],TREESAVED[INDTREE,1]); ! links the frames;
FRAME:HOWLINKED[TREESAVED[INDTREE,0]]←LNKSAVED[INDTREE];
END;
! kills $LAST instruction: only declarations, deletions, assignments
and tree operations can be killed. The value of $LAST indicates the
type of $LAST executed instruction;
PROCEDURE KILLCODE;
BEGIN
CASE $LAST OF
BEGIN "CASE"
[KIL] PRINT("sorry...I can't ",CRLF); ! unkillable instruction;
[DECL] WHILE INDADDR DO ! declaration;
BEGIN
! deletes the new created symbols, the frames are unlinked;
INDADDR←INDADDR-1;
$YMTAB[ADDRTYPE[INDADDR,0]]←NULL_RECORD;
IF ADDRTYPE[INDADDR,1]=#NWFR
THEN UNLNK_NODE(SYMBOL:OBJECT[ADDRPTR[INDADDR]]);
$SCLST←$VTLST←$RTLST←$TRLST←$FRLST←NULL;
END;
[DEL] BEGIN BOOLEAN TREE; ! deletion;
WHILE INDADDR DO
BEGIN
! inserts symbols deleted and restores values and tree structure;
INDADDR←INDADDR-1;
$YMTAB[ADDRTYPE[INDADDR,0]]←ADDRPTR[INDADDR];
IF ADDRTYPE[INDADDR,1]=#FR THEN TREE←TRUE;
CASE ADDRTYPE[INDADDR,1] OF
BEGIN
[#SC] SC_RECOVER;
[#VT] VT_RECOVER;
[#FR] FR_RECOVER;
[#RT] RT_RECOVER;
[#TR] TR_RECOVER
END;
END;
IF TREE
THEN WHILE INDTREE DO TREE_RECOVER;
END;
[ASG] BEGIN ! assignment;
! if symbol is a new defined one it is simply deleted, otherwise
old values and tree structure are restored ;
INTEGER IND;
WHILE INDADDR DO
BEGIN
INDADDR←INDADDR-1;
IND←ADDRTYPE[INDADDR,1];
IF IND=#NWFR
THEN BEGIN
UNLNK_NODE(SYMBOL:OBJECT[ADDRPTR[INDADDR]]);
$YMTAB[ADDRTYPE[INDADDR,0]]←NULL_RECORD;
END
ELSE IF IND=#NW
THEN BEGIN
$YMTAB[ADDRTYPE[INDADDR,0]]←NULL_RECORD;
$SCLST←$VTLST←$RTLST←$TRLST←NULL;
END
ELSE CASE IND OF
BEGIN
[#SC] SC_RECOVER;
[#VT] VT_RECOVER;
[#RT] RT_RECOVER;
[#FR] FR_RECOVER;
[#TR] TR_RECOVER
END;
END;
END;
[AFX] BEGIN ! affix/unfix;
! restores previous structure: if a new frame has been created
it is unlinked and deleted, otherwise previous values and
structure are restored;
INDADDR←INDADDR-1;
IF ADDRTYPE[0,1]=#NWFR
THEN BEGIN
UNLNK_NODE(SYMBOL:OBJECT[ADDRPTR[INDADDR]]);
$YMTAB[ADDRTYPE[INDADDR,0]]←NULL_RECORD;
END
ELSE BEGIN
TREE_RECOVER;
FR_RECOVER;
IF INDADDR>0
THEN BEGIN
INDADDR←INDADDR-1;
FR_RECOVER;
END;
END;
END;
[MRG] WHILE INDADDR DO ! merge;
BEGIN
! unlinks and deletes new frames;
INDADDR←INDADDR-1;
UNLNK_NODE(SYMBOL:OBJECT[ADDRPTR[INDADDR]]);
$YMTAB[ADDRTYPE[INDADDR,0]]←NULL_RECORD;
END;
[CPY] BEGIN ! copy;
WHILE INDADDR DO
BEGIN
! deletes new frames;
INDADDR←INDADDR-1;
$YMTAB[ADDRTYPE[INDADDR,0]]←NULL_RECORD;
END;
! unlinks the root of the subtree;
UNLNK_NODE(SYMBOL:OBJECT[ADDRPTR[INDADDR]]);
END
END "CASE";
UPDATE;
$LAST←KIL; ! unkillable instruction;
END;
! parse: number,nums,gettoken,namefile ;
! checks if num is a number or @;
SIMPLE BOOLEAN PROCEDURE NUMBER(INTEGER NUM);
BEGIN
IF 48≤NUM≤57 OR NUM=64 THEN RETURN(TRUE) ELSE RETURN(FALSE);
END;
! checks if the string word contains only numbers;
SIMPLE BOOLEAN PROCEDURE NUMS(STRING WORD);
BEGIN
STRING WW; INTEGER BR;
WW←SCAN(WORD,$NUMTAB,BR);
IF BR=0
THEN RETURN (TRUE)
ELSE RETURN (FALSE);
END;
! returns in head next token.If erroneous token is null;
PROCEDURE GETTOKEN (BOOLEAN NONSTOP(TRUE));
BEGIN "GETTOKEN"
STRING WORD,WORD2;
INTEGER BRPARS; LABEL AGAIN;
! reads next token using the indicated breaktable;
STRING PROCEDURE TOKEN(INTEGER BRTAB);
BEGIN "TOKEN"
STRING VAR;
VAR ←SCAN($TAIL,BRTAB,BRPARS);
RETURN (VAR);
END "TOKEN";
AGAIN: WORD←NULL;$TYPE ←#IDF;
TOKEN($SPCTAB); ! skips blanks;
WORD←WORD&TOKEN($RETAB); ! reads first token;
IF WORD=NULL
THEN IF BRPARS="."
THEN BEGIN ! no object read, period found;
TOKEN($SKTAB); ! reads the period;
TOKEN($ALFTAB); ! reads one character;
IF NUMBER(BRPARS)
THEN BEGIN
WORD←"."&TOKEN($NUMTAB); ! reads until finds numbers;
$TYPE ←#FLN; ! floating number read;
END
ELSE BEGIN
WORD←".";
$TYPE ←#PCT; ! period is only a punctuation mark;
END;
END
ELSE IF BRPARS=CR AND NONSTOP
THEN BEGIN
! a new line is required and then the token is read;
$LINE←INCHWL;
ESC_P;
$NEXT ←$NEXT &" "&$LINE;
IF $OUT THEN CPRINT($TTYCH,$LINE,CRLF);
$TAIL←SCAN($LINE,$SCNTAB,$BRCHR);
IF $BRCHR=0 THEN $TAIL←$TAIL&CR;
GO TO AGAIN;
END
ELSE BEGIN
WORD←BRPARS;
TOKEN($SKTAB);
$TYPE ←#PCT; ! punctuation mark found;
END
ELSE IF BRPARS="."
THEN IF NUMS(WORD)
THEN BEGIN
WORD←WORD&".";
TOKEN($SKTAB); ! reads the period;
TOKEN($ALFTAB); ! reads one character;
IF NUMBER(BRPARS)
THEN BEGIN ! there are more numbers;
WORD←WORD&TOKEN($NUMTAB);
$TYPE ←#FLN; ! floating number read;
END
ELSE BEGIN
$TYPE ←#FLN; ! floating number read;
END;
END;
$HEAD←WORD;
! checks if token is an integer number;
IF $TYPE =#IDF AND $HEAD
THEN BEGIN
WORD2←SCAN(WORD,$ALFTAB,BRPARS); ! reads one character;
IF NUMBER(BRPARS)
THEN BEGIN ! if first ch. is a number;
WORD2←SCAN(WORD,$NUMTAB,BRPARS);
IF BRPARS=0
THEN BEGIN ! only numbers found;
$TYPE ←#INT; ! integer number read;
$HEAD←WORD2;
RETURN;
END
ELSE BEGIN
ABORT ($SYNMSG[31],NULL);
$HEAD←NULL; ! incorrect token;
RETURN;
END
END
ELSE RETURN;
END
ELSE RETURN;
END "GETTOKEN";
! reads a file name and returns it ;
STRING PROCEDURE NAMEFILE;
BEGIN
STRING NAME;
GETTOKEN;
IF $TYPE =#IDF
THEN BEGIN "FILE"
NAME←$HEAD; ! name of file;
GETTOKEN(FALSE);
IF $HEAD="."
THEN BEGIN "EXT" ! extension;
GETTOKEN;
IF $TYPE =#IDF
THEN BEGIN
NAME←NAME&"."&$HEAD;
GETTOKEN(FALSE);
END
ELSE ABORT($SYNMSG[21],$SYNMSG[25]);
END "EXT"
ELSE IF $TYPE =#FLN
THEN BEGIN "NUM" ! if extension is a number;
STRING P;
P←LOP($HEAD);
IF P="."
THEN BEGIN
NAME←NAME&"."&$HEAD;
GETTOKEN(FALSE);
END
ELSE ABORT($SYNMSG[21],$SYNMSG[25]);
END "NUM"
END "FILE"
ELSE ABORT($SYNMSG[23],$SYNMSG[25]);
IF $HEAD="["
THEN BEGIN "PPN" ! there is ppn;
GETTOKEN;
IF $TYPE =#IDF OR $TYPE =#INT
THEN BEGIN "PR"
NAME←NAME&"["&$HEAD;
GETTOKEN;
IF $HEAD=","
THEN BEGIN "PN"
GETTOKEN; ! there is pn;
IF $TYPE =#IDF
THEN BEGIN "PAREN"
NAME←NAME&","&$HEAD;
GETTOKEN;
IF $HEAD="]"
THEN NAME←NAME&"]"
ELSE ABORT($SYNMSG[4],$SYNMSG[25]);
END "PAREN"
ELSE ABORT($SYNMSG[21],$SYNMSG[25]);
END "PN"
ELSE ABORT($SYNMSG[1],$SYNMSG[25]);
END "PR"
ELSE BEGIN
PRINT("--→ integer number ",$SYNMSG[25],"OR ");
ABORT($SYNMSG[21],$SYNMSG[25]);
END
END "PPN"
ELSE $TAIL←$HEAD&$TAIL;
RETURN(NAME);
END;
! returns true if the last token is a terminal character, CR or ;
SIMPLE BOOLEAN PROCEDURE FINAL;
BEGIN
IF $HEAD=SEMC OR $HEAD=CR
THEN RETURN(TRUE)
ELSE RETURN(FALSE);
END;
! parse: scalread,arrow_read,comma_read,semicol_read,rpar_read,lpar_read,idf_read,to_read,
hand_read,arm_read,into_read,axis_read;
! returns a real number with sign or the value of a scalar identifier;
REAL PROCEDURE SCALREAD;
BEGIN "scal"
REAL SCAL;STRING TEMP,SIGN;
GETTOKEN;
IF $TYPE = #IDF
THEN SCAL←SCALAR:VALUE[BELONGS($HEAD,#SC)]
ELSE
IF $HEAD="-" OR $HEAD="+"
THEN BEGIN
SIGN←$HEAD; ! if there is a sign + or -;
GETTOKEN;
IF $TYPE =#INT OR $TYPE =#FLN
THEN BEGIN
TEMP←SIGN&$HEAD;
SCAL←REALSCAN(TEMP,$BRCHR);
END
ELSE ABORT($SYNMSG[22],$SYNMSG[25]);
END
ELSE
IF $TYPE =#INT OR $TYPE =#FLN
THEN SCAL←REALSCAN($HEAD,$BRCHR)
ELSE BEGIN
PRINT($SYNMSG[21],$SYNMSG[25]," OR ");
ABORT($SYNMSG[22],$SYNMSG[25]);
END;
RETURN(SCAL);
END "scal";
SIMPLE PROCEDURE COMMA_READ;
BEGIN
GETTOKEN;
IF $HEAD≠"," THEN ABORT($SYNMSG[1],$SYNMSG[25]);
END;
SIMPLE PROCEDURE SEMICOL_READ;
BEGIN
GETTOKEN(FALSE);
IF NOT FINAL THEN ABORT($SYNMSG[0],$SYNMSG[25]);
END;
SIMPLE PROCEDURE RPAR_READ;
BEGIN
GETTOKEN;
IF $HEAD≠")" THEN ABORT($SYNMSG[6],$SYNMSG[25]);
END;
SIMPLE PROCEDURE LPAR_READ;
BEGIN
GETTOKEN;
IF $HEAD≠"(" THEN ABORT($SYNMSG[5],$SYNMSG[25]);
END;
SIMPLE PROCEDURE MOD_READ;
BEGIN
GETTOKEN;
IF $HEAD≠"|" THEN ABORT($SYNMSG[33],$SYNMSG[25]);
END;
SIMPLE STRING PROCEDURE IDF_READ;
BEGIN
GETTOKEN;
IF $TYPE ≠#IDF THEN ABORT($SYNMSG[21],$SYNMSG[25])
ELSE RETURN($HEAD);
END;
SIMPLE STRING PROCEDURE MVFR_READ;
BEGIN
GETTOKEN;
IF EQU($HEAD,"BY")
THEN BEGIN
$TAIL←$HEAD&$TAIL;
RETURN("BARM");
END
ELSE IF $TYPE=#IDF THEN RETURN($HEAD)
ELSE ABORT($SYNMSG[21],$SYNMSG[25]);
END;
SIMPLE PROCEDURE BY_READ;
BEGIN
GETTOKEN;
IF NOT EQU($HEAD,"BY")THEN ABORT($SYNMSG[10],$SYNMSG[25]);
END;
SIMPLE PROCEDURE TO_READ;
BEGIN
GETTOKEN;
IF NOT EQU($HEAD,"TO") THEN ABORT($SYNMSG[14],$SYNMSG[25]);
END;
SIMPLE PROCEDURE INTO_READ;
BEGIN
GETTOKEN;
IF NOT EQU($HEAD,"INTO") THEN ABORT($SYNMSG[11],$SYNMSG[25]);
END;
SIMPLE PROCEDURE TRANS_READ;
BEGIN
GETTOKEN;
IF NOT EQU($HEAD,"TRANS") THEN ABORT($SYNMSG[15],$SYNMSG[25]);
END;
SIMPLE PROCEDURE INCH_READ;
BEGIN
GETTOKEN;
IF NOT EQU($HEAD,"INCHES") AND NOT EQU($HEAD,"INCH")
THEN ABORT("--→ inches ",$SYNMSG[25]);
END;
SIMPLE PROCEDURE DEG_READ;
BEGIN
GETTOKEN;
IF NOT EQU($HEAD,"DEGREES") AND NOT EQU($HEAD,"DEG")
THEN ABORT("--→ degrees ",$SYNMSG[25]);
END;
SIMPLE STRING PROCEDURE HAND_READ;
BEGIN ! reads BHAND or YHAND (default= BHAND);
GETTOKEN;
IF EQU($HEAD,"BHAND") OR EQU($HEAD,"YHAND")
THEN RETURN($HEAD)
ELSE IF EQU($HEAD,"TO") OR EQU($HEAD,"BY")
THEN BEGIN
$TAIL←$HEAD&$TAIL;
RETURN("BHAND");
END
ELSE ABORT($SYNMSG[19],$SYNMSG[25]);
END;
SIMPLE STRING PROCEDURE ARM_READ;
BEGIN ! reads "BARM" or "YARM" (default=BARM);
GETTOKEN(FALSE);
IF EQU($HEAD,"YARM") OR EQU($HEAD,"BARM")
THEN BEGIN
STRING WHAT;
WHAT←$HEAD;
SEMICOL_READ;
RETURN(WHAT);
END
ELSE IF $HEAD=";" OR FINAL
THEN RETURN("BARM")
ELSE ABORT($SYNMSG[18],$SYNMSG[25]);
END;
SIMPLE STRING PROCEDURE DEV_READ;
BEGIN ! reads BARM/YARM/POINTER (default=POINTER);
GETTOKEN(FALSE);
IF EQU($HEAD,"POINTER") OR EQU($HEAD,"BARM") OR EQU($HEAD,"YARM")
THEN BEGIN
STRING POS;
POS←$HEAD;
SEMICOL_READ;
RETURN(POS);
END
ELSE IF FINAL OR $HEAD=";"
THEN RETURN("POINTER")
ELSE BEGIN
PRINT($SYNMSG[18],"OR POINTER ",$SYNMSG[25]," OR",CRLF);
ABORT($SYNMSG[0],$SYNMSG[25]);
END;
END;
SIMPLE STRING PROCEDURE AXIS_READ;
BEGIN ! reads XHAT/YHAT/ZHAT or X/Y/Z;
GETTOKEN;
IF EQU($HEAD,"XHAT") OR EQU($HEAD,"YHAT") OR EQU($HEAD,"ZHAT")
OR $HEAD="X" OR $HEAD="Y" OR $HEAD="Z"
THEN RETURN($HEAD[1 TO 1])
ELSE ABORT($SYNMSG[17],$SYNMSG[25]);
END;
! returns the WRT frame;
SIMPLE STRING PROCEDURE WRTCODE;
BEGIN
STRING RELFR; ! reads "{WRT <frame_id> }" ;
GETTOKEN(FALSE);
IF EQU($HEAD,"WRT")
THEN BEGIN "C"
RELFR←IDF_READ;
SEMICOL_READ;
RETURN(RELFR);
END "C"
ELSE IF FINAL
THEN RETURN("STATION")
ELSE BEGIN "E"
PRINT($SYNMSG[0],$SYNMSG[25], " OR ");
ABORT($SYNMSG[16],$SYNMSG[25]);
END "E"
END;
! returns the FROM frame "{FROM <frame>}" or STATION;
SIMPLE STRING PROCEDURE FROMPART;
BEGIN
STRING ROOT;
GETTOKEN(FALSE);
IF EQU($HEAD,"FROM")
THEN BEGIN
ROOT←IDF_READ;
SEMICOL_READ;
RETURN(ROOT);
END
ELSE IF FINAL
THEN RETURN("STATION")
ELSE BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ABORT("--→ FROM ",$SYNMSG[25]);
END;
END;
! returns WRT or REL or null ;
STRING PROCEDURE WRTREL(REFERENCE STRING HOW);
BEGIN
STRING RELFR; ! reads "{WRT/REL <frame_id> }" ;
HOW←NULL;
GETTOKEN(FALSE);
IF EQU($HEAD,"WRT") OR EQU($HEAD,"REL")
THEN BEGIN "C"
HOW←$HEAD;
RELFR←IDF_READ;
SEMICOL_READ;
RETURN(RELFR);
END "C"
ELSE IF FINAL
THEN RETURN(NULL)
ELSE BEGIN "E"
PRINT($SYNMSG[0],$SYNMSG[25], " OR ");
PRINT($SYNMSG[16],$SYNMSG[25]," OR ",CRLF);
ABORT($SYNMSG[12],$SYNMSG[25]);
END "E"
END;
SIMPLE PROCEDURE RPARINCH_READ;
BEGIN ! reads "){*INCHES|INCH}" ;
RPAR_READ;
GETTOKEN(FALSE);
IF $HEAD="*"
THEN INCH_READ
ELSE $TAIL←$HEAD&" "&$TAIL;
END;
SIMPLE PROCEDURE RPARDEG_READ;
BEGIN ! reads "{*DEGREES|DEG} )";
GETTOKEN;
IF $HEAD="*"
THEN DEG_READ
ELSE $TAIL←$HEAD&" "&$TAIL;
RPAR_READ;
END;
! parse: rt_read, vt_read,vect_part,rot_part,trans_part,explicit;
! reads an explicit rotation and returns the pointer to the rot;
RPTR(ROT)PROCEDURE RT_READ;
BEGIN ! <axis>,<scalar>);
REAL ARRAY A[1:5,1:4];
RPTR(ROT) TEMP; STRING AXIS;REAL ANGLE;
AXIS←AXIS_READ;
COMMA_READ;
ANGLE←SCALREAD;
RPARDEG_READ;
TEMP←NEW_RECORD(ROT);
A[1,1]←A[2,2]←A[3,3]←A[4,4]←1.0;
MEMORY[LOCATION(A)]↔MEMORY[LOCATION(ROT:XF[TEMP])];
XYZ_ROTATION(ROT:XF[TEMP],AXIS,ANGLE);
RETURN(TEMP);
END;
! reads an explicit vector and returns the pointer to the vector;
RPTR(VECTOR) PROCEDURE VT_READ;
BEGIN ! <scalar>,<scalar>,<scalar>){*INCHES};
RPTR(VECTOR) TEMP;
TEMP←NEW_RECORD(VECTOR);
VECTOR:XC[TEMP]←SCALREAD;
COMMA_READ;
VECTOR:YC[TEMP]←SCALREAD;
COMMA_READ;
VECTOR:ZC[TEMP]←SCALREAD;
RPARINCH_READ;
RETURN(TEMP);
END;
! reads {<scalar>*}<vector> or {<scalar>*}<expl.vector>. Scalar is read
with its sign, if there is;
RPTR(VECTOR) PROCEDURE VECT_PART;
BEGIN
REAL VAL,SCAL;INTEGER TYPE;STRING TEMP;RPTR(VECTOR)RESULT,COMP;
GETTOKEN;
IF EQU($HEAD,"NILVECT") THEN RETURN(V_NILVECT);
VAL←1;
IF $HEAD="-"
THEN BEGIN VAL←-1;GETTOKEN;END
ELSE IF $HEAD="+"
THEN GETTOKEN;
TEMP←$HEAD; TYPE←$TYPE;
GETTOKEN(FINAL);
IF $HEAD="*"
THEN BEGIN
IF TYPE = #IDF
THEN SCAL←SCALAR:VALUE[BELONGS(TEMP,#SC)]
ELSE
IF TYPE =#INT OR TYPE =#FLN
THEN SCAL←REALSCAN(TEMP,$BRCHR)
ELSE BEGIN
PRINT($SYNMSG[21],$SYNMSG[25]," OR ");
ABORT($SYNMSG[22],$SYNMSG[25]);
END;
VAL←VAL*SCAL;
END
ELSE $TAIL←TEMP&" "&$HEAD&" "&$TAIL;
GETTOKEN;
IF EQU($HEAD,"VECTOR")
THEN LPAR_READ;
IF $HEAD="("
THEN COMP←VT_READ
ELSE
IF $TYPE =#IDF
THEN COMP←BELONGS ($HEAD,#VT)
ELSE ABORT($SYNMSG[21],$SYNMSG[25]);
IF VAL≠1
THEN BEGIN
RESULT←NEW_RECORD(VECTOR);
OPSCVT(VAL,COMP,RESULT,"*");
RETURN(RESULT);
END
ELSE RETURN(COMP);
END;
RPTR(ROT)PROCEDURE ROT_PART;
BEGIN "RP"
RPTR(ROT)TEMP1,TEMP2;
RPTR(ROT)PROCEDURE ROT_COMP;
BEGIN "RC"
IF EQU($HEAD,"ROT") THEN LPAR_READ;
IF $HEAD="("
THEN RETURN(RT_READ)
ELSE IF $TYPE =#IDF
THEN RETURN(BELONGS ($HEAD,#RT))
ELSE BEGIN
PRINT($SYNMSG[13],$SYNMSG[25]," OR ");
ABORT($SYNMSG[5],$SYNMSG[25]);
END;
END "RC";
GETTOKEN;
IF EQU($HEAD,"NILROTN")
THEN RETURN(R_NILROTN);
TEMP1←ROT_COMP;
GETTOKEN(FALSE);
WHILE $HEAD="*" DO
BEGIN
GETTOKEN;
TEMP2←ROT_COMP;
TEMP1←MULRTRT(TEMP1,TEMP2);
GETTOKEN;
END;
$TAIL←$HEAD&$TAIL;
RETURN(TEMP1);
END "RP";
! reads the trans part of an explicit frame and returns th pointer to the
created record;
RPTR(TRANS) PROCEDURE TRANS_PART;
BEGIN "A"
RPTR(ROT)TMPRT;RPTR(VECTOR)TMPVT;
TMPRT←ROT_PART;
COMMA_READ;
TMPVT←VECT_PART;
RPAR_READ;
RETURN(DOTR(TMPRT,TMPVT));
END "A";
! reads an explicit vector or frame and returns it in array comp with
6 numbers if frame, with first 3 if vector ;
PROCEDURE EXPLICIT (REAL ARRAY COMP;REFERENCE INTEGER N);
BEGIN "EX"
INTEGER I;
COMP[1]←SCALREAD;
I←2;
DO BEGIN "LOOP"
GETTOKEN;
IF $HEAD="*"
THEN BEGIN
GETTOKEN;
IF NOT EQU($HEAD,"INCHES")
THEN ABORT("--→ inches",$SYNMSG[25]);
GETTOKEN;
END;
IF $HEAD=","
THEN COMP[I]←SCALREAD
ELSE IF $HEAD=")"
THEN BEGIN "D"
N←I-1;
RETURN;
END "D"
ELSE ABORT($SYNMSG[1],$SYNMSG[25]);
I←I+1;
END "LOOP"
UNTIL I>6 ;
N←I-1;
RPAR_READ;
END "EX";
! parse procedures: affixproc,assign,bailcall;
! parses the instruction
AFFIX <frame_id> TO <frame_id> {AT TRANS(<rot>,<vector>)};
PROCEDURE AFFIXPROC;
BEGIN
STRING FR1,FR2;INTEGER AFFTYPE;
$HELP←0;
FR1←IDF_READ; ! first frame;
TO_READ;
FR2←IDF_READ; ! second frame;
GETTOKEN(FALSE);
IF EQU($HEAD,"AT")
THEN BEGIN "AT"
RPTR(TRANS)COMP;
TRANS_READ; ! reads TRANS word;
LPAR_READ;
COMP←TRANS_PART; ! reads the trans part;
! assigns to fr1 the value of comp as relative to fr2;
ASGFREXP(FR1,COMP,FR2);
GETTOKEN(FALSE);
END "AT";
IF FINAL
THEN AFFIXCODE(FR1,FR2,#RGDLK)
ELSE BEGIN "D"
IF $HEAD="+" OR EQU($HEAD,"NONRIGIDLY")
THEN AFFTYPE← #NRGLK
ELSE IF $HEAD="*" OR EQU($HEAD,"RIGIDLY")
THEN AFFTYPE← #RGDLK
ELSE ABORT($SYNMSG[30],NULL);
SEMICOL_READ;
AFFIXCODE(FR1,FR2,AFFTYPE);
END "D";
END ;
! parses the instruction
<identifier>←<variable> {<op> <variable>};
PROCEDURE ASSIGN(STRING FIRST);
BEGIN
STRING RELFR;
INTEGER TYPE1,TYPE2;STRING ARG1,ARG2,OP;
IF $HEAD="+" OR $HEAD="-"
THEN BEGIN
OP←$HEAD; ! first arg. is a number;
GETTOKEN;
IF $TYPE =#INT OR $TYPE =#FLN
THEN ARG1←OP&$HEAD
ELSE ABORT($SYNMSG[22],$SYNMSG[25]);
END
ELSE IF $TYPE ≠#PCT
THEN ARG1←$HEAD
ELSE BEGIN
PRINT($SYNMSG[22],$SYNMSG[25]," OR ");
ABORT($SYNMSG[21],$SYNMSG[25]);
END;
TYPE1←$TYPE ;
GETTOKEN(FALSE);
IF $TYPE =#PCT
THEN IF FINAL
THEN BEGIN
$HELP←3;
ASGCODE(FIRST,ARG1,TYPE1);
END
ELSE IF $HEAD="+" OR
$HEAD="-" OR
$HEAD="*" OR
$HEAD="/" OR
$HEAD="." OR
$HEAD="→"
THEN BEGIN
$HELP←2;
OP←$HEAD;
GETTOKEN;
IF $HEAD AND $TYPE ≠#PCT
THEN BEGIN
ARG2←$HEAD;
TYPE2←$TYPE ;
SEMICOL_READ;
ARITHCODE(FIRST,ARG1,OP,ARG2,TYPE1,TYPE2);
END
ELSE BEGIN
PRINT($SYNMSG[22],$SYNMSG[25]," OR ");
ABORT($SYNMSG[21],$SYNMSG[25]);
END
END
ELSE ABORT($SYNMSG[24],$SYNMSG[25])
ELSE IF TYPE1=#IDF AND (EQU($HEAD,"WRT") OR EQU($HEAD,"REL"))
THEN BEGIN
$HELP←25;
OP←$HEAD;
RELFR←IDF_READ;
SEMICOL_READ;
ASGVTFR(FIRST,ARG1,OP,RELFR);
END
ELSE BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR");
PRINT($SYNMSG[16],$SYNMSG[25]," OR",CRLF);
ABORT($SYNMSG[24],$SYNMSG[25]);
END;
END;
PROCEDURE AXISPROC(STRING FIRST);
BEGIN
RPTR(ROT)COMP;
$HELP← 42;
LPAR_READ;
GETTOKEN;
IF EQU($HEAD,"ROT")
THEN LPAR_READ;
IF $HEAD="("
THEN COMP←RT_READ
ELSE
IF $TYPE=#IDF
THEN COMP←BELONGS($HEAD,#RT)
ELSE ABORT($SEMSG[2],NULL);
RPAR_READ;
SEMICOL_READ;
AXISCODE(FIRST,COMP);
END;
IFC #DEBUG THENC
EXTERNAL PROCEDURE BAIL;
ENDC
PROCEDURE BAILCALL;
BEGIN
SEMICOL_READ;
$ALLOW←$ALLOW+1; ! no display with bail;
IFC #DEBUG THENC BAIL; ENDC
$ALLOW←$ALLOW-1;
END;
! parse procedures: centerproc,opclproc,constread,copyproc;
! parses the instruction
CENTER <arm>;
PROCEDURE CENTERPROC;
BEGIN "A"
STRING POS;
$HELP←5;
POS←ARM_READ; ! if the arm is not indicated BARM is assumed;
CENTERCODE(POS);
END "A";
! parses the part of the instruction "<scalar>;
PROCEDURE OPENING(STRING FIRST,WHAT,HOW);
BEGIN
REAL SCAL;
$HELP←6;
SCAL←SCALREAD;
SEMICOL_READ;
OLDSAV(FIRST,WHAT); ! saves for default instructions;
OPCLCODE(FIRST,WHAT,HOW,SCAL);
END;
! parses the instructions
OPEN <hand> TO|BY <scalar>;
! CLOSE <hand> TO|BY <scalar>;
PROCEDURE OPCLPROC(STRING FIRST);
BEGIN
STRING WHAT,HOW;
$HELP←6;
WHAT←HAND_READ;
HOW←IDF_READ;
IF EQU(HOW,"TO") OR EQU(HOW,"BY")
THEN OPENING(FIRST,WHAT,HOW)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ABORT($SYNMSG[14],$SYNMSG[25]);
END;
END;
! closes any open file, after a confirmation;
PROCEDURE FCLPROC;
BEGIN
STRING ANSWER;
$HELP←37;
SEMICOL_READ;
PRINT("Any open file will be closed. Are you sure?");
ANSWER←INCHRW;
PRINT(CRLF);
ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN FCLOSE
ELSE ABORT1("CLOSE_FILE",$SEMSG[15]);
TTYSAVE;
END;
! parses the instructions
CLOSE {<filename>} (default=last used file)
CLOSE <hand> TO|BY <scalar> (BHAND as default);
PROCEDURE CLOSEPROC;
BEGIN
STRING FL,ANSWER;
$HELP←1;
GETTOKEN(FALSE);
IF FINAL THEN
AL_CLOSE($ALFL)
ELSE
BEGIN "MORE"
IF EQU($HEAD,"BHAND") OR EQU($HEAD,"YHAND")
OR EQU($HEAD,"TO") OR EQU($HEAD,"BY")
THEN BEGIN "HAND"
STRING WHAT; INTEGER IND;
WHAT←$HEAD;
GETTOKEN(FALSE);
IF FINAL
THEN BEGIN "FILECHECK"
IND←ALFILE(WHAT);
IF IND THEN
BEGIN
PRINT("do you want to close the file?");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN AL_CLOSE(WHAT)
ELSE ABORT1("CLOSE",$SEMSG[15]);
END
ELSE
IF EQU(WHAT,"BHAND") OR EQU(WHAT,"YHAND") THEN
BEGIN
STRING HOW;
HOW←IDF_READ;
IF EQU(HOW,"BY") OR EQU(HOW,"TO")
THEN OPENING("CLOSE",WHAT,HOW)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ABORT($SYNMSG[14],$SYNMSG[25]);
END;
END
ELSE OPENING("CLOSE","BHAND",WHAT);
END "FILECHECK"
ELSE
IF EQU(WHAT,"TO") OR EQU(WHAT,"BY") THEN
BEGIN
$TAIL←$HEAD&$TAIL;
OPENING("CLOSE","BHAND",WHAT); ! default=BHAND;
END
ELSE
IF EQU($HEAD,"TO") OR EQU($HEAD,"BY") THEN
OPENING("CLOSE",WHAT,$HEAD)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ABORT($SYNMSG[14],$SYNMSG[25]);
END;
END "HAND"
ELSE
BEGIN
$TAIL←$HEAD&$TAIL;
FL←NAMEFILE;
SEMICOL_READ;
AL_CLOSE(FL);
END;
END "MORE";
END;
! reads a comment. This procedure is called when { is found;
PROCEDURE COMMNT;
BEGIN
$TAIL←SCAN($LINE,$CMNTAB,$BRCHR); ! scans the command;
WHILE $BRCHR=0
DO BEGIN
$LINE←INCHWL; ! if } not found reads again;
IF $OUT THEN CPRINT($TTYCH,$LINE,CRLF);
$TAIL←SCAN($LINE,$CMNTAB,$BRCHR);
END;
END;
! parses the instruction
CONSTRUCT {<frame_id>,<frame_id>,<frame_id>};
PROCEDURE CONSTR(STRING FIRST);
BEGIN "READ"
STRING FR1,FR2,FR3;
$HELP←7;
GETTOKEN(FALSE);
IF $TYPE ≠#IDF
THEN IF FINAL
THEN IMPLCONSTR(FIRST)
ELSE BEGIN
PRINT($SYNMSG[0],$SYNMSG[25],"OR");
ABORT($SYNMSG[21],$SYNMSG[25]);
END
ELSE BEGIN
FR1←$HEAD;
COMMA_READ;
FR2←IDF_READ;
COMMA_READ;
FR3←IDF_READ;
SEMICOL_READ;
CONSTRCODE(FIRST,FR1,FR2,FR3);
END;
END "READ";
! parses the instructions
MERGE <frame_id> INTO <frame_id>
COPY <frame_id> INTO <frame_id>
First is MERGE or COPY;
PROCEDURE COPYPROC(STRING FIRST);
BEGIN
STRING FR1,FR2;
$HELP←8;
FR1←IDF_READ; ! reads first frame;
INTO_READ; ! reads INTO;
FR2←IDF_READ; ! reads second frame;
SEMICOL_READ;
COPYCODE(FIRST,FR1,FR2);
END;
! parse procedures: declproc,deleteproc,driveproc,editproc,exitproc,explass,freeproc;
! parses the declaration instructions
SCALAR <id>,<id>,...
VECTOR <id>,<id>,...
FRAME <id>,<id>,...
ROT <id>,<id>,...;
PROCEDURE DECLPROC (INTEGER OBTYPE);
BEGIN
$HELP←9;
DO BEGIN "A"
GETTOKEN;
IF $TYPE ≠#IDF
THEN ABORT($SYNMSG[21],$SYNMSG[25])
ELSE DECLCODE($HEAD,OBTYPE);
GETTOKEN(FALSE);
IF $HEAD≠"," AND NOT FINAL
THEN BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ABORT($SYNMSG[1],$SYNMSG[25] );
END;
END "A"
UNTIL FINAL;
END;
! used after reading DISTANCE to read VECTOR in declaration statement;
PROCEDURE DIMPROC;
BEGIN
STRING VET;
VET←IDF_READ;
IF EQU(VET,"VECTOR")
THEN DECLPROC(#VT)
ELSE ABORT($SYNMSG[34],NULL);
END;
! parses the instructions
DELETE <variable>,<variable>,..
DELETE (deletes all the variables defined by the user);
PROCEDURE DELETEPROC;
BEGIN
STRING VAR;
$HELP←10;
GETTOKEN(FALSE);
IF FINAL
THEN BEGIN ! deletes all the variables;
STRING ANSWER;
PRINT("are you sure? ");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN RESET
ELSE ABORT1("DELETE",$SEMSG[15]);
END
ELSE BEGIN
$TAIL←$HEAD&$TAIL;
$ALLOW←$ALLOW+1;
DO BEGIN "A"
VAR←IDF_READ;
KILLVAR($HEAD);
GETTOKEN(FALSE);
IF $HEAD≠"," AND NOT FINAL
THEN BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ABORT($SYNMSG[1],$SYNMSG[25] );
END;
END "A"
UNTIL FINAL;
$ALLOW←$ALLOW-1;
UPDATE;
END;
END;
! reads, for DRIVE instruction, TO|BY <scalar>;
PROCEDURE JT_READ(STRING WHAT,HOW;INTEGER JOINT);
BEGIN "J"
REAL SCAL;
$HELP←11;
SCAL←SCALREAD;
SEMICOL_READ;
OLDSAV("DRIVE",CVS(JOINT)); ! saves for default instructions;
DRIVECODE(WHAT,HOW,JOINT,SCAL);
END "J";
! parses the instruction
DRIVE BJT|YJT (#) TO|BY <scalar>;
PROCEDURE DRIVEPROC;
BEGIN
STRING HOW;
STRING WHAT;INTEGER JOINT;
$HELP←11;
WHAT←IDF_READ;
IF EQU(WHAT,"BJT") OR EQU(WHAT,"YJT")
THEN BEGIN
LPAR_READ; ! reads "(number)";
GETTOKEN;
JOINT←INTSCAN($HEAD,$BRCHR);
IF JOINT<1 OR JOINT>7
THEN ABORT(joint,"joint not existent");
RPAR_READ;
HOW←IDF_READ;
IF EQU(HOW,"BY") OR EQU(HOW,"TO")
THEN JT_READ(WHAT,HOW,JOINT)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ABORT($SYNMSG[14],$SYNMSG[25]);
END;
END
ELSE ABORT("--→ BJT or YJT ",$SYNMSG[25]);
END;
PROCEDURE EDITPROC;
BEGIN
STRING VAR;
$HELP←12;
VAR←IDF_READ;
SEMICOL_READ;
EDITCODE(VAR);
END;
PROCEDURE EXITPROC;
BEGIN
$HELP←13;
SEMICOL_READ;
!SKIP!←ALT ;
END;
PROCEDURE EXPLRT(STRING FIRST);
BEGIN "R"
RPTR(ROT)TEMP;
$HELP←26;
! LPAR_READ;
TEMP←ROT_PART; ! era rt_read;
SEMICOL_READ;
ASGEXP(FIRST,TEMP,#RT);
END "R";
PROCEDURE EXPLVT(STRING FIRST);
BEGIN
RPTR(VECTOR)COMP;STRING RELFR,OP;
$HELP←27;
LPAR_READ;
COMP←VT_READ;
RELFR←WRTREL(OP);
! vt←<exp.vet> REL/WRT RELFR;
IF RELFR
THEN ASGVTEXP(FIRST,COMP,OP,RELFR)
ELSE ASGEXP(FIRST,COMP,#VT); ! vt←<exp.vet>;
END;
PROCEDURE EXPLFR(STRING FIRST); ! frame←FRAME(rot,vet);
BEGIN
RPTR(TRANS)COMP; STRING OP,RELFR;
$HELP←28;
LPAR_READ;
COMP←TRANS_PART;
RELFR←WRTREL(OP);
IF EQU(OP,"WRT")
THEN BEGIN
PRINT($SYNMSG[12],$SYNMSG[25]," OR ");
ABORT($SYNMSG[0],$SYNMSG[25]);
END;
ASGFREXP(FIRST,COMP,RELFR);
END;
PROCEDURE EXPLTR(STRING FIRST); ! frame←TRANS(rot,vet);
BEGIN
RPTR(TRANS)COMP;
$HELP← 38;
LPAR_READ;
COMP←TRANS_PART;
SEMICOL_READ;
ASGEXP(FIRST,COMP,#TR);
END;
PROCEDURE EXPLASS(STRING FIRST);
BEGIN "A"
REAL ARRAY COMP[1:6];INTEGER NN;
RPTR(TRANS) TEMP;
STRING RELFR,OP;
GETTOKEN;
IF EQU($HEAD,"XHAT") OR EQU($HEAD,"YHAT") OR EQU($HEAD,"ZHAT")
THEN BEGIN ! it's a rotation;
RPTR(ROT)TEMPR;
$HELP←26;
$TAIL←"("&$HEAD&$TAIL; ! ERA SENZA (;
TEMPR←ROT_PART; ! era rt_read;
SEMICOL_READ;
ASGEXP(FIRST,TEMPR,#RT);
END
ELSE BEGIN "TRANS"
RPTR(SYMBOL)EL;
IF $HEAD="(" OR EQU($HEAD,"ROT")
OR ( $TYPE=#IDF AND EL←CHECK($HEAD,#RT))
THEN BEGIN
$TAIL←$HEAD&$TAIL;
TEMP←TRANS_PART;
RELFR←WRTREL(OP);
IF EQU(OP,"WRT")
THEN BEGIN
PRINT($SYNMSG[12],$SYNMSG[25]," OR ");
ABORT($SYNMSG[0],$SYNMSG[25]);
END;
IF OP
THEN ASGFREXP(FIRST,TEMP,RELFR)
ELSE ASGEXP(FIRST,TEMP,#TR);
END
ELSE BEGIN
$HELP←29;
$TAIL←$HEAD&$TAIL;
EXPLICIT(COMP,NN);
RELFR←WRTREL(OP);
IF NN=3
THEN BEGIN
RPTR(VECTOR)TEMP;
TEMP←NEW_RECORD(VECTOR);
PUTVTVAL(TEMP,COMP);
IF RELFR
THEN ASGVTEXP(FIRST,TEMP,OP,RELFR)
ELSE ASGEXP(FIRST,TEMP,#VT);
END
ELSE IF NN=6
THEN BEGIN
IF EQU(OP,"WRT")
THEN ABORT($SYNMSG[12],$SYNMSG[25]);
TEMP←DOTREXP(COMP[1],COMP[2],COMP[3],
COMP[4],COMP[5],COMP[6]);
IF OP
THEN ASGFREXP(FIRST,TEMP,RELFR)
ELSE ASGEXP(FIRST,TEMP,#TR);
END
ELSE BEGIN
PRINT($SYNMSG[26],$SYNMSG[27]," OR ");
ABORT($SYNMSG[26],$SYNMSG[29]);
END;
END;
END "TRANS";
END "A";
! parse procedures: inputproc,killproc,vtrtpart,moveproc,axmovproc;
PROCEDURE INPUTPROC(STRING FIRST;INTEGER DIRECT);
BEGIN
STRING POS;
$HELP←14;
POS←DEV_READ;
INPUTCODE(FIRST,DIRECT,POS);
END;
PROCEDURE KILLPROC;
BEGIN
$HELP←15;
SEMICOL_READ;
KILLCODE ;
END;
PROCEDURE VTRTPART(STRING FIRST;INTEGER TYPE);
BEGIN
STRING FRA;
IF TYPE=#VT THEN $HELP←16 ELSE $HELP← 20;
LPAR_READ;
FRA←IDF_READ;
IF EQU(FRA,"INPUT")
THEN BEGIN
GETTOKEN;
IF EQU($HEAD,"BARM") OR EQU($HEAD,"YARM") OR EQU($HEAD,"POINTER")
THEN BEGIN
FRA←$HEAD;
RPAR_READ;
SEMICOL_READ;
INPT(FRA);
END
ELSE IF $HEAD=")"
THEN BEGIN
FRA←"POINTER";
SEMICOL_READ;
INPT(FRA);
END
ELSE BEGIN
PRINT($SYNMSG[18],"OR POINTER ",$SYNMSG[25]," OR",CRLF);
ABORT($SYNMSG[6],$SYNMSG[25]);
END;
END
ELSE BEGIN
RPAR_READ;
SEMICOL_READ;
END;
VTRTCODE(FIRST,FRA,TYPE);
END;
! moves the frame fr1 along axis by scal;
PROCEDURE ALONGPROC(STRING AXIS,FRA1);
BEGIN
REAL SCAL;RPTR(VECTOR)COMP;
$HELP←18;
SCAL←SCALREAD;
SEMICOL_READ;
COMP←NEW_RECORD(VECTOR);
IF AXIS="X" THEN VECTOR:XC[COMP]←SCAL
ELSE IF AXIS="Y" THEN VECTOR:YC[COMP]←SCAL
ELSE VECTOR:ZC[COMP]←SCAL;
OLDSAV("MOVE"&AXIS,FRA1); ! saves for default instructions;
MVFREXP(FRA1,FRA1,COMP ,"STATION");
END;
! moves the frame along one axis by a scalar;
PROCEDURE AXMOVPROC;
BEGIN
STRING FRA1,AXIS;
$HELP←18;
AXIS←$HEAD[5 TO 5];
FRA1←MVFR_READ;
BY_READ;
ALONGPROC(AXIS,FRA1);
END;
! move <frame> by <expl.vector>{wrt <frame>};
! move <frame> by <vector>{wrt <frame>};
PROCEDURE BYPROC(STRING FR1);
BEGIN
STRING RELFR; RPTR(VECTOR) COMP;
$HELP←17;
COMP←VECT_PART; ! reads {<scala>*}<vector>;
RELFR←WRTCODE;
OLDSAV("MOVE",FR1);
MVFREXP(FR1,FR1,COMP,RELFR);
END;
! move frame to frame+vector;
! move frame to frame + expl.vector wrt frame;
PROCEDURE TOPROC(STRING FR1);
BEGIN
STRING FR2,RELFR; RPTR(VECTOR) COMP;
$HELP←17;
RELFR←NULL; ! if there is no vector there is no WRT frame;
FR2←IDF_READ;
GETTOKEN(FALSE);
IF FINAL
THEN COMP←V_NILVECT
ELSE
IF $HEAD="+" OR $HEAD="-"
THEN BEGIN
$TAIL←$HEAD&$TAIL;
COMP←VECT_PART;
RELFR←WRTCODE;
END
ELSE ABORT($SYNMSG[7],$SYNMSG[25]);
OLDSAV("MOVE",FR1);
MVFREXP(FR1,FR2,COMP,RELFR);
END;
! reads move <frame_id> to/by/along <axis> ;
PROCEDURE MOVEPROC;
BEGIN
STRING FR1,AXIS;
$HELP←17;
FR1←IDF_READ;
GETTOKEN;
IF EQU($HEAD,"TO")
THEN TOPROC(FR1)
ELSE IF EQU($HEAD,"BY")
THEN BYPROC(FR1)
ELSE IF EQU($HEAD,"ALONG")
THEN BEGIN
AXIS←AXIS_READ;
BY_READ;
ALONGPROC(AXIS,FR1);
END
ELSE ABORT($SYNMSG[9],$SYNMSG[25]);
END;
PROCEDURE MODPROC(STRING FIRST);
BEGIN "MOD"
RANY WHAT;
$HELP←40;
GETTOKEN;
IF EQU($HEAD,"ROT")
THEN BEGIN
LPAR_READ;
WHAT←RT_READ;
MOD_READ;
SEMICOL_READ;
MODRT(FIRST,WHAT);
END
ELSE
IF EQU($HEAD,"VECTOR")
THEN BEGIN
LPAR_READ;
WHAT←VT_READ;
MOD_READ;
SEMICOL_READ;
MODVT(FIRST,WHAT);
END
ELSE
IF $HEAD="("
THEN BEGIN "A"
GETTOKEN;
IF EQU($HEAD,"XHAT") OR EQU($HEAD,"YHAT") OR EQU($HEAD,"ZHAT")
THEN BEGIN
$TAIL←$HEAD&$TAIL;
WHAT←RT_READ;
MOD_READ;
SEMICOL_READ;
MODRT(FIRST,WHAT);
END
ELSE BEGIN
$TAIL←$HEAD&$TAIL;
WHAT←VT_READ;
MOD_READ;
SEMICOL_READ;
MODVT(FIRST,WHAT);
END;
END "A"
ELSE
IF $TYPE=#IDF
THEN BEGIN
RPTR(SYMBOL)EL;INTEGER OBTYPE;STRING TEMP;
TEMP←$HEAD;
MOD_READ;
SEMICOL_READ;
EL←CHECKTOT(TEMP,OBTYPE);
IF OBTYPE=#SC
THEN MODSC(FIRST,SYMBOL:OBJECT[EL])
ELSE
IF OBTYPE=#VT
THEN MODVT(FIRST,SYMBOL:OBJECT[EL])
ELSE
IF OBTYPE=#RT
THEN MODRT(FIRST,SYMBOL:OBJECT[EL])
ELSE ABORT(temp,$SEMSG[17]);
END
ELSE BEGIN
REAL NUM;
$TAIL←$HEAD&$TAIL;
NUM←SCALREAD;
MOD_READ;
SEMICOL_READ;
WHAT←NEW_RECORD(SCALAR);
SCALAR:VALUE[WHAT]←NUM;
MODSC(FIRST,WHAT);
END
END "MOD";
PROCEDURE UNITPROC(STRING FIRST);
BEGIN
RPTR(VECTOR)COMP;
$HELP← 39;
LPAR_READ;
GETTOKEN;
IF EQU($HEAD,"VECTOR")
THEN LPAR_READ;
IF $HEAD="("
THEN COMP←VT_READ
ELSE
IF $TYPE=#IDF
THEN COMP←BELONGS($HEAD,#VT)
ELSE ABORT($SEMSG[1],NULL);
RPAR_READ;
SEMICOL_READ;
UNITCODE(FIRST,COMP);
END;
! parse procedures: other;
PROCEDURE DEFLT(STRING HOW);
BEGIN
IF EQU(OLDCMD,"OPEN") OR EQU(OLDCMD,"CLOSE")
THEN OPENING(OLDCMD,OLDOBJ,HOW)
ELSE IF EQU(OLDCMD,"MOVEX")OR EQU(OLDCMD,"MOVEY")OR EQU(OLDCMD,"MOVEZ")
THEN IF HOW="BY"
THEN ALONGPROC(OLDCMD[5 FOR 1],OLDOBJ)
ELSE ABORT($SYNMSG[10],$SYNMSG[25])
ELSE IF EQU(OLDCMD,"DRIVE")
THEN JT_READ("BJT",HOW,CVD(OLDOBJ))
ELSE IF EQU(OLDCMD,"MOVE")
THEN IF HOW="BY"
THEN BYPROC(OLDOBJ)
ELSE TOPROC(OLDOBJ);
END;
PROCEDURE ASGMNT(STRING FIRST);
BEGIN "A"
IF EQU(FIRST,"BARM") OR EQU(FIRST,"YARM")
THEN BEGIN
GETTOKEN(FALSE);
IF FINAL
THEN BEGIN
IF EQU(FIRST,"BARM")
THEN READARM(F_BARM)
ELSE READARM(F_YARM);
$FRLST←NULL;UPDATE;
RETURN;
END;
END
ELSE GETTOKEN;
IF EQU($HEAD,"CONSTRUCT")
THEN CONSTR(FIRST)
ELSE IF EQU($HEAD,"INPUT")
THEN INPUTPROC(FIRST,#INDEF)
ELSE IF $HEAD="↑" OR $HEAD="↓" or $head="α"
or $head="<" or $head=">" or $head="∨" or $head="∧"
THEN BEGIN "INPUT"
INTEGER DIRECT;
DIRECT←$HEAD; ! direct=orientation required;
GETTOKEN;
IF EQU($HEAD,"INPUT")
THEN INPUTPROC(FIRST,DIRECT)
ELSE ABORT($SYNMSG[20],$SYNMSG[25]);
END "INPUT"
ELSE IF EQU($HEAD,"ROT")
THEN EXPLRT(FIRST)
ELSE IF EQU($HEAD,"VECTOR")
THEN EXPLVT (FIRST)
ELSE IF EQU($HEAD,"FRAME")
THEN EXPLFR(FIRST)
ELSE IF EQU($HEAD,"TRANS")
THEN EXPLTR(FIRST)
ELSE IF $HEAD="("
THEN EXPLASS(FIRST)
ELSE IF EQU($HEAD,"POS")
THEN VTRTPART(FIRST,#VT)
ELSE IF EQU($HEAD,"ORIENT")
THEN VTRTPART(FIRST,#RT)
ELSE IF EQU($HEAD,"UNIT")
THEN UNITPROC(FIRST)
ELSE IF EQU($HEAD,"AXIS")
THEN AXISPROC(FIRST)
ELSE IF EQU($HEAD,"|")
THEN MODPROC(FIRST)
ELSE ASSIGN (FIRST);
END "A";
PROCEDURE OTHER;
BEGIN
STRING FIRST;
$HELP←4;
FIRST←$HEAD;
GETTOKEN;
IF $HEAD="←"
THEN ASGMNT(FIRST)
ELSE IF EQU(first,"BY") OR EQU(first,"TO")
THEN BEGIN
$TAIL←$HEAD&$TAIL;
DEFLT(FIRST);
END
ELSE ABORT($SYNMSG[32],NULL);
END;
! parse procedures: parking,readproc,renmproc,writeproc,unfixproc;
PROCEDURE PARKING;
BEGIN
STRING PAR;
$HELP←19 ;
PAR←$HEAD;
SEMICOL_READ;
$LAST←KIL;
IF PAR="BPARK"
THEN GOARM(F_BARM,FRAME:XF[F_BPARK],1)
ELSE IF PAR="PARK"
THEN BEGIN
GOARM(F_BARM,FRAME:XF[F_BPARK],1);
GOARM(F_YARM,FRAME:XF[F_YPARK]);
END
ELSE GOARM(F_YARM,FRAME:XF[F_YPARK]);
$FRLST←NULL;
UPDATE;
END;
PROCEDURE READPROC;
BEGIN
STRING FILE;
$HELP←21;
GETTOKEN(FALSE);
IF FINAL
THEN READCODE("DECLAR.AL")
ELSE BEGIN
$TAIL←$HEAD&$TAIL;
FILE←NAMEFILE;
SEMICOL_READ;
READCODE(FILE);
END;
END;
PROCEDURE RENMPROC;
BEGIN
STRING VAR;
$HELP←22;
VAR←IDF_READ;
SEMICOL_READ;
RENMCODE(VAR);
END;
PROCEDURE SAVEPROC;
BEGIN
STRING FILE;
$HELP← 30;
GETTOKEN(FALSE);
IF FINAL
THEN SAVECODE($ALFL)
ELSE BEGIN
FILE←NAMEFILE;
SEMICOL_READ;
SAVECODE(FILE);
END;
END;
PROCEDURE FSAVPROC;
BEGIN
$HELP←41;
SEMICOL_READ;
FSAVE;
END;
PROCEDURE WRITEPROC;
BEGIN "A"
STRING FILE,ROOT;
$HELP←24;
GETTOKEN(FALSE);
IF FINAL
THEN WRITECODE($ALFL,"STATION")
ELSE IF EQU($HEAD,"FROM")
THEN BEGIN
ROOT←IDF_READ;
SEMICOL_READ;
WRITECODE($ALFL,ROOT);
END
ELSE BEGIN "B"
$TAIL←$HEAD&$TAIL;
FILE←NAMEFILE;
ROOT←FROMPART;
WRITECODE(FILE,ROOT);
END "B"
END "A";
PROCEDURE UNFIXPROC;
BEGIN
STRING FR1,FR2;
$HELP←23;
FR1←IDF_READ;
FR2←FROMPART;
UNFIXCODE(FR1,FR2);
END;
! parse;
RECURSIVE PROCEDURE PARSE;
BEGIN "PARSE"
INTEGER FIRSTCH;
GETTOKEN; ! reads first token;
IF $HEAD="?"
THEN HELPREQUEST
ELSE IF EQU($HEAD,"COMMENT")
THEN BEGIN END
ELSE IF $HEAD="{"
THEN COMMNT
ELSE IF EQU($HEAD,"KILL")
THEN KILLPROC
ELSE BEGIN
KILLINI; ! initialization of stacks for kill;
FIRSTCH←$HEAD[1 FOR 1]; ! first character determines
the entry in case table;
! code of A=65,code of Z=90;
IF 65≤ FIRSTCH ≤90 THEN
CASE FIRSTCH - 65 OF
BEGIN "CASE"
[0] IF EQU($HEAD ,"AFFIX") THEN AFFIXPROC
ELSE OTHER;
[1] IF EQU($HEAD,"BPARK") THEN PARKING
ELSE IF EQU($HEAD,"BAIL") THEN BAILCALL
ELSE OTHER;
[6][7][8][9][10][11][13][16][23][25] OTHER;
[2] IF EQU($HEAD ,"CENTER") THEN CENTERPROC
ELSE IF EQU($HEAD ,"CLOSE") THEN CLOSEPROC
ELSE IF EQU($HEAD ,"CLOSE_FILES") THEN FCLPROC
ELSE IF EQU($HEAD ,"COPY") THEN COPYPROC($HEAD )
ELSE OTHER;
[3] IF EQU($HEAD,"DELETE") THEN DELETEPROC
ELSE IF EQU($HEAD,"DRIVE") THEN DRIVEPROC
ELSE IF EQU($HEAD,"DISTANCE") THEN DIMPROC
ELSE OTHER;
[4] IF EQU($HEAD ,"EXIT") THEN EXITPROC
ELSE IF EQU($HEAD ,"EDIT") THEN EDITPROC
ELSE OTHER;
[5] IF EQU($HEAD ,"FRAME") THEN DECLPROC(#FR)
ELSE OTHER;
[12] IF EQU($HEAD ,"MOVE") THEN MOVEPROC
ELSE IF EQU($HEAD,"MOVEX") OR EQU($HEAD,"MOVEY")
OR EQU($HEAD,"MOVEZ") THEN AXMOVPROC
ELSE IF EQU($HEAD ,"MERGE") THEN COPYPROC($HEAD )
ELSE OTHER;
[14] IF EQU($HEAD ,"OPEN") THEN OPCLPROC($HEAD )
ELSE OTHER;
[15] IF EQU($HEAD,"PARK") THEN PARKING
ELSE OTHER;
[17] IF EQU($HEAD ,"READ") THEN READPROC
ELSE IF EQU($HEAD ,"ROT") THEN DECLPROC(#RT)
ELSE IF EQU($HEAD,"RENAME") THEN RENMPROC
ELSE OTHER;
[18] IF EQU($HEAD,"SCALAR") THEN DECLPROC(#SC)
ELSE IF EQU($HEAD,"SAVE") THEN SAVEPROC
ELSE IF EQU($HEAD,"SAVE_FILES") THEN FSAVPROC
ELSE OTHER;
[19] IF EQU($HEAD,"TRANS") THEN DECLPROC(#TR)
ELSE OTHER;
[20] IF EQU($HEAD ,"UNFIX") THEN UNFIXPROC
ELSE OTHER;
[21] IF EQU($HEAD ,"VECTOR") THEN DECLPROC(#VT)
ELSE OTHER;
[22] IF EQU($HEAD ,"WRITE") THEN WRITEPROC
ELSE OTHER;
[24] IF EQU($HEAD,"YPARK") THEN PARKING
ELSE OTHER
END "CASE"
ELSE BEGIN
$HELP←36;
ABORT($SYNMSG[31],NULL);
END;
END;
END "PARSE";
! prints the 5 x 4 array;
PROCEDURE ARRPRINT(REAL ARRAY BBB);
BEGIN INTEGER I,J;
FOR I←1 STEP 1 UNTIL 4 DO
BEGIN
FOR J←1 STEP 1 UNTIL 4 DO
PRINT(" ",BBB[I,J]);
PRINT(CRLF);
END;
END;
REAL ARRAY JOINTS[1:7];
REAL ARRAY MATRIX[1:5,1:4];
! reads and prints the arm position (the complete matrix, the decoded
values and the relative values);
PROCEDURE BLUEREAD;
BEGIN
REAL ARRAY AXF[1:5,1:4]; REAL W,PH,TH;
READ_BLUE(AXF);
PRINT(" read values of arm position ",CRLF);
ARRPRINT(AXF);
DECODE_ROTATION(AXF,W,PH,TH);
PRINT("ARM POSITION= ",W," ",PH," ",TH," ",AXF[1,4]," ",AXF[2,4]," ",
AXF[3,4],CRLF);
END;
! prints the values of the indicated frame and moves BARM to it;
PROCEDURE GOFRAME(STRING NAME);
BEGIN
RPTR(FRAME) EL;
EL←BELONGS(NAME,#FR);
BLUEREAD;
PRINT("computed values for final arm position ",CRLF);
ARRPRINT(FRAME:XF[EL]);
MOVE_B(FRAME:XF[EL]);
SETABSXF(F_BARM,FRAME:XF[EL]);
END;
! main program;
! REQUIRE "INIT.MLG[1,MLG]" SOURCE_FILE;
$ALLOW←$ALLOW+1;
! some initializations;
$READ←FALSE; ! used by readcode: true while reading;
$ALFL←"DECLAR.AL"; ! default name for input/output file;
$EPS←0.01;
HANDB ←NEW_SC("BHAND"); S_BHAND ←SYMBOL:OBJECT[HANDB];
HANDY ←NEW_SC("YHAND"); S_YHAND ←SYMBOL:OBJECT[HANDY];
XHAT ←NEW_VT("XHAT"); V_XHAT ←SYMBOL:OBJECT[XHAT];
YHAT ←NEW_VT("YHAT"); V_YHAT ←SYMBOL:OBJECT[YHAT];
ZHAT ←NEW_VT("ZHAT"); V_ZHAT ←SYMBOL:OBJECT[ZHAT];
NILVECT ←NEW_VT("NILVECT"); V_NILVECT ←SYMBOL:OBJECT[NILVECT];
WORLD ←NEW_FR("STATION"); F_WORLD ←SYMBOL:OBJECT[WORLD];
BPARK ←NEW_FR("BPARK"); F_BPARK ←SYMBOL:OBJECT[BPARK];
YPARK ←NEW_FR("YPARK"); F_YPARK ←SYMBOL:OBJECT[YPARK];
YARM ←NEW_FR("YARM"); F_YARM ←SYMBOL:OBJECT[YARM];
BARM ←NEW_FR("BARM"); F_BARM ←SYMBOL:OBJECT[BARM];
BGRASP ←NEW_FR("BGRASP"); F_BGRASP ←SYMBOL:OBJECT[BGRASP];
POINTER ←NEW_FR("POINTER"); F_POINTER ←SYMBOL:OBJECT[POINTER];
NILROTN ←NEW_RT("NILROTN"); R_NILROTN ←SYMBOL:OBJECT[NILROTN];
NILTRANS←NEW_TR("NILTRANS"); T_NILTRANS←SYMBOL:OBJECT[NILTRANS];
PARK←DOTREXP(0,180,0,43.53125,56.855,9.95875);
ARRTRAN(FRAME:XF[F_BPARK],TRANS:XF[PARK]); ! definition of BPARK;
PARK←DOTREXP(0,180,0,40,14,9);
ARRTRAN(FRAME:XF[F_YPARK],TRANS:XF[PARK]); ! definition of YPARK;
AFX_NODE(F_BARM,F_WORLD,#NRGLK);
AFX_NODE(F_YARM,F_WORLD,#NRGLK);
PARK←DOTREXP(-180,180,0,0,0,0); ! definition of BGRASP;
ARRTRAN(FRAME:XF[F_BGRASP],TRANS:XF[PARK]);
AFX_NODE(F_BGRASP,F_BARM,#RGDLK);
PARK←DOTREXP(-.417,13.2,-5.173,.0121,.119,3.75); ! definition of POINTER;
ARRTRAN(FRAME:XF[F_POINTER],TRANS:XF[PARK]);
AFX_NODE(F_POINTER,F_BARM,#RGDLK);
ARM←F_BARM;
PUTVT(V_XHAT,1.,0.,0.);
PUTVT(V_YHAT,0.,1.,0.);
PUTVT(V_ZHAT,0.,0.,1.);
READARM(F_BARM);
$ALLOW←$ALLOW-1;
OLDVAL←TTYUP(TRUE); ! conversion to upper cases;
IFC #HELP THENC HELPER;ENDC ! for non expert users;
TTYSAVE; ! allows opening a file to save
tty outputs;
DPYCLR;
UPDATE;
PRINT("give instructions or <meta-control-ALT> to exit",CRLF,"* ");
WHILE TRUE DO
BEGIN
IF $READ THEN READEXEC;
$LINE←INCHWL; ! reads one line on tty;
IF !SKIP!= ALT THEN DONE; ! ALT=cntrl-meta-alt;
IF $OUT THEN CPRINT($TTYCH,$LINE,CRLF); ! saves the typed line;
! to allow more than one instruction in one input line;
WHILE $LINE DO
BEGIN
$NEXT ←$LINE; ! saves the line;
! $BRCHR←0;$TAIL←NULL;$HEAD←NULL;
$TAIL←SCAN($LINE,$SCNTAB,$BRCHR); ! scans until ? or { or ;
IF $BRCHR=0 THEN $TAIL←$TAIL&CR; ! if no break found adds a CR;
PARSE; ! parses the instruction;
END;
IF !SKIP!=ALT THEN DONE; ! EXIT instruction read;
PRINT("* ");ESC_P;
MAINL: END;
GOARM(F_BARM,FRAME:XF[F_BPARK]); ! parks the arm;
PRINT("bye,bye",CRLF);
loded("dea elf"&CRLF&CRLF);
END;